



		    before_journal_manager_.alm     04/04/85  1114.9re  04/04/85  0824.3       52713



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
"
"	 The main transfer vector for before journal manager primitives.
"
"
" HISTORY:
"
" Written by M. Pandolf, 07/09/82.
" Modified:
" 08/20/82 by M. Pandolf: to handle dm_data_ init pathology.
" 08/31/82 by M. Pandolf: added two phase system initialization.
" 10/28/82 by M. Pandolf: added find_old_uid_pn_table.
" 11/03/82 by M. Pandolf: added real delete_bj entry point.
" 11/09/82 by M. Pandolf: added adjust_process_id entry point.
" 11/15/82 by M. Pandolf: changed get_bj_path to get_bj_path_from_oid.
" 01/07/83 by Lee A. Newcomb: added find_old_uid_pn_table,
"	    find_txns_after_crash, open_all_after_crash,
"	    and rebuild_after_crash.
" 01/10/83 by L. A. Newcomb: added clear_txn_tables.
" 02/24/83 by M. Pandolf & J. Ives: to call bjm_gate_.
" 04/13/83 by M. Pandolf: added get_journal_status.
" 04/19/83 by Jeffrey D. Ives: to call6 instead of tra, so gates work.
" 04/26/83 by L. A. Newcomb: added close_bj_for_recovery
"	    and open_bj_for_recovery.
" 06/08/83 by L. A. Newcomb: added flush_all.
" 08/01/83 by Lindsey Spratt:  added the open_bj_force entry.
" 08/11/83 by M. Pandolf: to use bjm_firstref_tv_ as needed.
" 08/17/83 by L. A. Newcomb: to special case part one per-system init.
"	    to not go through the inner ring tv or user gate.  The
"	    caller must already be in the DMS ring.
" 09/09/83 by L. A. Newcomb: renamed part one system init. program &
"	    remove obs. per_process_init entry that just returned.
" 10/14/83 by L. A. Newcomb: fixed bm_firstref_tv_ missing "j".
" 01/03/84 by L. A. Newcomb: changed all gate references to dm_gate_
"	    from bjm_gate_, adding the macro gate_transfer to do so.
"	    This macro prefixes bjm_ to a gate target entry name.
" 03/01/84 by L. A. Newcomb: changed so entries that do not go through
"	    gates will only tra, not call6.
" 04/06/84 by R. Michael Tague:  changed entry adjust_process_id and entry
"	    flush_all to call through dm_daemon_gate_ instead of dm_gate_.
" 04/12/84 by R. Michael Tague:  changed open_bj_force to not go through gate.
" 04/19/84 by R. Michael Tague: changed get_bj_path_from_uid to call through
"	    dm_daemon_gate_ instead of dm_gate_.
" 05/02/84 by Lee A. Newcomb:  added user_shutdown entry.
" 07/06/84 by Lindsey Spratt:  Changed get_bj_path_from_uid to go through the
"	    dm_admin_gate_ instead of dm_daemon_gate_.  It is used by "txn
"	    status" to get the bj pathname when listing other processes'
"	    txn's before journals.
" 10/29/84 by Matthew Pierret:  Added write_fm_rollback_handler and
"             write_fm_postcommit_handler.
" 11/22/84 by Lee A. Newcomb:  Added $per_process_init entry
" 12/03/84 by Stanford S. Cox: Renamed *inner_ring_tv_ to be =firstref_tv_
" 12/14/84 by Lee A. Newcomb:  Added entries for file system extended objects
"	    support:  $add_acl_entries, $chname_file, $delete_acl_entries,
"	    $get_user_access_modes, $list_acl, $replace_acl, and $validate.
" 03/20/85 by Lee A. Newcomb:  Added $set_transaction_storage_limit.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	before_journal_manager_


"	macros to transfer to gates or bjm_firstref_tv_.

	macro	transfer		" we are in DM ring, just tra
	entry	&1
&1:	tra	&2$&1
	&end

	macro	gate_transfer	" call may be from outside the DM ring,
	entry	&1
&1:	call6	&2$bjm_&1		" ALWAYS prefix the name
	&end


	entry 	per_system_init_1	"special cased to not go through
per_system_init_1:			"inner ring tv or user gate
	tra	bjm_per_system_init_1_$bjm_per_system_init_1_

	transfer		abandon,bjm_firstref_tv_
	gate_transfer	add_acl_entries,dm_gate_
	gate_transfer	adjust_process_id,dm_daemon_gate_
	transfer		adopt,bjm_firstref_tv_
	gate_transfer	chname_file,dm_gate_
	transfer		clear_txn_tables,bjm_firstref_tv_
	gate_transfer	close_bj,dm_gate_
	transfer		close_bj_after_recovery,bjm_firstref_tv_
	gate_transfer	create_bj,dm_gate_
	gate_transfer	delete_acl_entries,dm_gate_
	gate_transfer	delete_bj,dm_gate_
	transfer		find_old_uid_pn_table,bjm_firstref_tv_
	transfer		find_txns_after_crash,bjm_firstref_tv_
	gate_transfer	flush_all,dm_daemon_gate_
	transfer		flush_transaction,bjm_firstref_tv_
	gate_transfer	get_bj_oid,dm_gate_
	gate_transfer	get_bj_path_from_oid,dm_gate_
	gate_transfer	get_bj_path_from_uid,dm_admin_gate_
	gate_transfer	get_default_bj,dm_gate_
	gate_transfer	get_journal_status,dm_gate_
	gate_transfer	get_user_access_modes,dm_gate_
	gate_transfer	list_acl,dm_gate_
	transfer		open_all_after_crash,bjm_firstref_tv_
	gate_transfer	open_bj,dm_gate_
	transfer		open_bj_for_recovery,bjm_firstref_tv_
	transfer		open_bj_force,bjm_firstref_tv_
	transfer		per_process_init,bjm_firstref_tv_
	transfer		per_system_init_2,bjm_firstref_tv_
	transfer		rebuild_after_crash,bjm_firstref_tv_
	gate_transfer	replace_acl,dm_gate_
	transfer		rollback,bjm_firstref_tv_
	gate_transfer	set_default_bj,dm_gate_

" set_transaction_storage_limit must be done specially since the
" bjm_ prefix makes the target entryname too long.
	entry	set_transaction_storage_limit
set_transaction_storage_limit:
	call6	dm_gate_$bjm_set_txn_storage_limit

	transfer		user_shutdown,bjm_firstref_tv_
	gate_transfer	validate,dm_gate_
	transfer		write_aborted_mark,bjm_firstref_tv_
	transfer		write_before_image,bjm_firstref_tv_
	transfer		write_begin_mark,bjm_firstref_tv_
	transfer		write_committed_mark,bjm_firstref_tv_
          transfer            write_fm_postcommit_handler,bjm_firstref_tv_
          transfer            write_fm_rollback_handler,bjm_firstref_tv_
	transfer		write_rolled_back_mark,bjm_firstref_tv_

	end




		    before_journal_meters.pl1       10/16/90  1527.6rew 10/16/90  1518.7      217089



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






/****^  HISTORY COMMENTS:
  1) change(90-09-10,Zimmerman), approve(90-09-10,MCR8199),
     audit(90-10-12,Gray), install(90-10-16,MR12.4-1043):
     Cause -rr and -rs to reset metering time, generate stats in absence of
     before_journal, correct attemp to print no-existant data when process is
     non-priveledged.
                                                   END HISTORY COMMENTS */





/* DESCRIPTION:
   before_journal_meters - command level interface to bjm_get_journal_status
   and interface to ring zero meters in dm_journal_seg_

   usage:
	bjmt [JNL_PATH1 ... JNL_PATHn] [-rr] [-rs] [-lg]
*/

/* HISTORY:
Written by M. Pandolf, 09/01/83.
Modified:
01/01/84 by M. Pandolf: to add .bj suffix to pathnames and fix reference
            to dm_journal.
12/03/84 by Maggie Sharpe:  to use ERROR_RETURN; to reference dm_journal_segp
            only if metering_regions_filled is on; cleaned up dcls and format.
12/13/84 by R. Michael Tague: Added -bf control argument.
12/17/84 by R. Michael Tague: Rationalized control argument flag settings.
01/16/85 by R. Michael Tague: Stopped the -lg argument from causing the 
            user_wants_meters_printed flag to be set.
02/14/85 by R. Michael Tague: Changed the -bf argument so that it would not
            set the user_wants_meters_printed flag.
03/19/85 by S. Cox: Added dm_not_available_ handler.
03/27/85 by Lee A. Newcomb:  Added reporting of the new
            transaction_storage_limit_hits per-journal meter.
04/09/85 by Lee A. Newcomb:  To use convert_access_class_ and not the obsolete
            convert_authorization_.
*/

/* format: style2 */

before_journal_meters:
bjmt:
     procedure () options (variable);


/* DECLARATIONS */

/* Automatic */

	dcl     arg_count		 fixed bin;	/* number of command line args */
	dcl     status_code		 fixed bin (35);	/* standard system status code */
	dcl     user_wants_meters_reset
				 bit (1) aligned;	/* true if ctl arg was -rr or -rs */
	dcl     user_wants_meters_printed
				 bit (1) aligned;	/* true if ctl arg was -rr, -lg, or <absent> */
	dcl     user_wants_long_report bit (1) aligned;	/* true if ctl arg was -lg */
	dcl     arg_number		 fixed bin;	/* index into command line args */
	dcl     arg_ptr		 pointer;		/* pointer to a command line arg */
	dcl     arg_length		 fixed bin (21);	/* length of command line arg pointed to by arg_ptr */
	dcl     metering_regions_filled
				 bit (1) aligned;	/* true if current copy of dm_journal_seg_ is available */
	dcl     journal_seg_max_length fixed bin (19);	/* self explanatory */
	dcl     binary_time		 fixed bin (71);	/* standard clock time */
	dcl     ascii_time		 char (24);	/* above time, but readable by Joe Average */
	dcl     area_ptr		 pointer;		/* used instead of many calls to get_system_free_area_ */
	dcl     bj_index		 fixed bin;	/* index into bj_status for one journal */
	dcl     bj_dir		 char (168);	/* directory path of dir containing journal */
	dcl     bj_entry		 char (32);	/* entry name of journal */
	dcl     new_ptr		 pointer dim (1);	/* pointer to copy of current ring 0 meter image */
	dcl     old_ptr		 pointer dim (1);	/* pointer to copy of previous ring 0 meter image */
	dcl     total_metering_time	 fixed bin (71);	/* raw number of seconds for this meter */
	dcl     total_metering_seconds fixed bin;	/* number of seconds for display */
	dcl     total_metering_minutes fixed bin;	/* number of minutes for display */
	dcl     total_metering_hours	 fixed bin;	/* number of hours for display */
	dcl     avg_n_bytes_per_bi	 fixed bin (71);	/* self explanatory */
	dcl     avg_n_ci_per_recycle	 fixed bin (71);	/* self explanatory */
	dcl     avg_n_bytes_per_txn	 fixed bin (71);	/* self explanatory */
	dcl     avg_n_bi_per_txn	 fixed bin (71);	/* self explanatory */
	dcl     total_bi_bytes	 fixed bin (71);	/* sum of all before bytes written in journal */
	dcl     total_bi_written	 fixed bin (71);	/* sum of all bi written, incl recycled */
	dcl     total_non_null_txns	 fixed bin (71);	/* count of txns having > 0 records */
	dcl     total_recycles	 fixed bin (71);	/* self explanatory */
	dcl     total_ci_recycled	 fixed bin (71);	/* sum of no. times each ci recycled */
	dcl     local_area		 area;		/* allocate and forget about freeing */
	dcl     is_pathname_ptr	 pointer;		/* self explanatory */
	dcl     no_path_specified	 bit (1);		/* true if command line specifies no path */

/* Based */

	dcl     arg		 char (arg_length) based (arg_ptr);
	dcl     first_arg_char	 char (1) based (arg_ptr);
	dcl     is_pathname		 dim (arg_count) bit (1) aligned based (is_pathname_ptr);

/* Builtin */

	dcl     (addr, clock, divide, empty, mod, null, unspec)
				 builtin;

/* Constant */

	dcl     (
	        IOA_GENERAL_RS_NO_NEW_LINE
				 bit (1) aligned init ("0"b),
	        IOA_GENERAL_RS_DONT_PAD
				 bit (1) aligned init ("1"b),
	        MY_NAME		 char (32) init ("before_journal_meters")
	        )			 internal static options (constant);

/* Entry */

	dcl     before_journal_manager_$get_journal_status
				 entry (char (*), char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     com_err_		 entry () options (variable);
	dcl     convert_access_class_$to_string
				 entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$general_rs	 entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
				 bit (1) aligned);
	dcl     metering_util_$define_regions
				 entry options (variable);
	dcl     metering_util_$fill_buffers
				 entry (fixed bin, fixed bin (71), char (*), (*) ptr, (*) ptr, fixed bin (35));
	dcl     metering_util_$reset	 entry (fixed bin, fixed bin (35));
	dcl     ring_zero_peek_$get_max_length
				 entry (char (*), fixed bin (19), fixed bin (35));

/* Condition */

	dcl     dm_not_available_	 condition;

/* External Static */

	dcl     dm_error_$system_not_initialized
				 fixed bin (35) ext static;
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
          dcl     error_table_$no_info   fixed bin (35) ext static;

/* Internal Static */

	dcl     Metering_regions_defined
				 bit (1) aligned internal static variable init ("0"b);
	dcl     Region_id		 fixed bin internal static variable init (0);
	dcl     Saved_bj_global_meters_ptr
				 pointer internal static variable init (null ());
	dcl     Saved_bj_status_ptr	 pointer internal static variable init (null ());


%page;
	on dm_not_available_ call ERROR_RETURN (dm_error_$system_not_initialized, "");

/* obtain argument info for this command */

	call cu_$arg_count (arg_count, status_code);
	if status_code ^= 0
	then do;
		call com_err_ (status_code, MY_NAME);
		goto MAIN_RETURN;
	     end;


/* analyze the args, looking for either a control arg or a pathname */

	user_wants_meters_reset = "0"b;
	user_wants_meters_printed = "1"b;
	user_wants_long_report = "0"b;

	allocate is_pathname in (local_area);
	is_pathname (*) = "0"b;
	no_path_specified = "1"b;

	new_ptr (1) = null ();
	old_ptr (1) = null ();

arg_processing_loop:
	do arg_number = 1 to arg_count;
	     call cu_$arg_ptr (arg_number, arg_ptr, arg_length, status_code);
	     if arg_length > 0
	     then if (arg = "-report_reset") | (arg = "-rr")
		then user_wants_meters_reset, user_wants_meters_printed = "1"b;
		else if (arg = "-reset") | (arg = "-rs")
		then do;
			user_wants_meters_reset = "1"b;
			user_wants_meters_printed = "0"b;
		     end;
		else if (arg = "-long") | (arg = "-lg")
		then user_wants_long_report = "1"b;
		else if (arg = "-brief") | (arg = "-bf")
		then user_wants_long_report = "0"b;
		else if first_arg_char = "-"
		then call ERROR_RETURN (error_table_$bad_arg, "^/The argument is ""^a"".", arg);
		else do;
			is_pathname (arg_number) = "1"b;
			no_path_specified = "0"b;
		     end;
	     else call ERROR_RETURN (error_table_$bad_arg, "^/One of the supplied arguments is """".");


	end arg_processing_loop;

/* get a copy of the ring zero meters */

	metering_regions_filled = "0"b;

	if ^Metering_regions_defined
	then do;
		call ring_zero_peek_$get_max_length ("dm_journal_seg_", journal_seg_max_length, status_code);
		if status_code = 0
		then do;
			call metering_util_$define_regions (Region_id, status_code, "dm_journal_seg_", 0,
			     journal_seg_max_length);
			if status_code = 0
			then Metering_regions_defined = "1"b;
		     end;
	     end;

	if Metering_regions_defined
	then do;
		call metering_util_$fill_buffers (Region_id, binary_time, ascii_time, new_ptr, old_ptr, status_code);
		if status_code = 0
		then metering_regions_filled = "1"b;
		else if status_code ^= error_table_$no_info 
		     then call com_err_ (MY_NAME,status_code," :unable to load system meter buffers. ");
		
	     end;
	else /* status_code set in prev do group */
	     call ERROR_RETURN (status_code, "^/Undefined metering regions.");

	dm_journal_segp = new_ptr (1);

/* process each pathname obtained from the command line */

	area_ptr = get_system_free_area_ ();

	if ^user_wants_meters_printed
	then goto should_we_reset_meters;

	if no_path_specified
	then do;

		call before_journal_manager_$get_journal_status ("", "system", area_ptr, bj_status_ptr,
		     bj_global_meters_ptr, status_code);
		if status_code ^= 0
		then call ERROR_RETURN (status_code, "^/Unable to get status of the default before journal.");

		else do;
			call PRINT_GLOBAL_METERS ();

			do bj_index = 1 to bj_status.n_journals;
			     call PRINT_ONE_JOURNAL (bj_index);
			end;

			if bj_status.n_journals = 0
			then call ioa_ ("^/There are no journals currently active.^/");
			free bj_status_ptr -> bj_status;
			free bj_global_meters_ptr -> bj_global_meters;
		     end;
	     end;
	else do arg_number = 1 to arg_count;

		if ^is_pathname (arg_number)
		then goto /* go WHAT?? */ done_with_pathname;

		call cu_$arg_ptr (arg_number, arg_ptr, arg_length, status_code);
		call expand_pathname_$add_suffix (arg, "bj", bj_dir, bj_entry, status_code);
		if status_code ^= 0
		then call ERROR_RETURN (status_code, "^/Supplied journal pathname is ""^a"".", arg);

		else do;
			call before_journal_manager_$get_journal_status (bj_dir, bj_entry, area_ptr, bj_status_ptr,
			     bj_global_meters_ptr, status_code);
			if status_code ^= 0
			then call ERROR_RETURN (status_code, "^/Supplied journal pathname is ""^a"".", arg);

			else do;
				call PRINT_ONE_JOURNAL (1);
				free bj_status_ptr -> bj_status;
				free bj_global_meters_ptr -> bj_global_meters;
			     end;
		     end;

done_with_pathname:
	     end;

/* fulfill any other committments to the user */

should_we_reset_meters:
	if user_wants_meters_reset
	then do;
		if Saved_bj_global_meters_ptr ^= null ()
		then free Saved_bj_global_meters_ptr -> bj_global_meters;
		if Saved_bj_status_ptr ^= null ()
		then free Saved_bj_status_ptr -> bj_status;
		call before_journal_manager_$get_journal_status ("", "system", area_ptr, Saved_bj_status_ptr,
		     Saved_bj_global_meters_ptr, status_code);
		Saved_bj_global_meters_ptr -> bj_global_meters.time_of_bootload = clock();
		call metering_util_$reset (Region_id, status_code);
		if status_code ^= 0 then call com_err_(status_code, " reported by metering_util_$reset while attempting to reset meters.");
		
	     end;

MAIN_RETURN:
	return;

%page;

/* INTERNAL PROCEDURES */

ERROR_RETURN:
     proc options (variable);

	dcl     (
	        er_arg_list_ptr	 ptr,
	        er_code		 fixed bin (35),
	        er_message		 char (1024),
	        er_message_length	 fixed bin (21)
	        )			 automatic;

	dcl     (
	        er_fixed_bin_35_value	 fixed bin (35),
	        er_message_overlay	 char (er_message_length)
	        )			 based;

	call cu_$arg_list_ptr (er_arg_list_ptr);
	er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_fixed_bin_35_value;

	call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message, er_message_length, IOA_GENERAL_RS_DONT_PAD,
	     IOA_GENERAL_RS_NO_NEW_LINE);
	call com_err_ (er_code, MY_NAME, addr (er_message) -> er_message_overlay);

	goto MAIN_RETURN;				/* does not return */

     end ERROR_RETURN;



PRINT_GLOBAL_METERS:
     procedure ();

	dcl     i			 fixed bin;

/* see if we have old copy of the meters for deltas */

	if Saved_bj_global_meters_ptr = null ()
	then do;
		allocate bj_global_meters set (Saved_bj_global_meters_ptr);
		unspec (Saved_bj_global_meters_ptr -> bj_global_meters) = ""b;
		Saved_bj_global_meters_ptr -> bj_global_meters.time_of_bootload =
		     bj_global_meters_ptr -> bj_global_meters.time_of_bootload;
	     end;

/* calculate metering time */

	total_metering_time =
	     divide (clock () - Saved_bj_global_meters_ptr -> bj_global_meters.time_of_bootload, 1000000, 71, 0);
	total_metering_seconds = mod (total_metering_time, 60);
	total_metering_minutes = mod (divide (total_metering_time, 60, 71, 0), 60);
	total_metering_hours = divide (total_metering_time, 3600, 71, 0);

	call ioa_ ("^/Total metering time:^2x^i:^[0^]^i:^[0^]^i^/", total_metering_hours, (total_metering_minutes < 10),
	     total_metering_minutes, (total_metering_seconds < 10), total_metering_seconds);

/* begin the report */

	if metering_regions_filled
	then do;
		call ioa_ ("");
		call ioa_ ("Journals in use^31t^d of ^d", dm_journal_segp -> dm_journal.n_journals_inuse,
		     dm_journal_segp -> dm_journal.n_journals);
		call ioa_ ("Pages held^31t^d of ^d (^d per journal).", dm_journal_segp -> dm_journal.n_held_pages_mem,
		     dm_journal_segp -> dm_journal.max_held_pages_mem, dm_journal_segp -> max_held_per_journal);

		call ioa_ ("Segments active in");
		do i = 0 to 3;
		     call ioa_ ("^5t^[4K^;16K^;64K^;256K^] pool^31t^d of ^d", i + 1,
			dm_journal_segp -> dm_journal.n_active (i), dm_journal_segp -> dm_journal.threshold (i));
		end;
	     end;

	if ^user_wants_long_report
	then return;

	call ioa_ ("^/Calls to");
	call ioa_ ("^5tbegin transaction^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_begin_txn
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_begin_txn);
	call ioa_ ("^5twrite before image^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_before_image
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_before_image);
	call ioa_ ("^5twrite abort mark^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_abort
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_abort);
	call ioa_ ("^5twrite commit mark^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_commit
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_commit);
	call ioa_ ("^5twrite fm post commit^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_fm_pc_mark
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_fm_pc_mark);
	call ioa_ ("^5twrite fm rollback handler^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_fm_rbh
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_fm_rbh);
	call ioa_ ("^5twrite rollback mark^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_rb_mark
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_rb_mark);
	call ioa_ ("^5trollback^31t^i",
	     bj_global_meters_ptr -> bj_global_meters.n_calls_rollback
	     - Saved_bj_global_meters_ptr -> bj_global_meters.n_calls_rollback);

	if metering_regions_filled
	then do;
		call ioa_ ("^/Synch write");
		call ioa_ ("^5tattempts^31t^i", dm_journal_segp -> dm_journal.synch_write_calls);
		call ioa_ ("^5tholds^31t^i", dm_journal_segp -> dm_journal.synch_write_holds);
		call ioa_ ("^5tinvalid - null DM stamp^31t^i", dm_journal_segp -> dm_journal.synch_write_no_stamp);
		call ioa_ ("^5tinvalid - bad DM stamp^31t^i", dm_journal_segp -> dm_journal.synch_write_inv_vers);
		call ioa_ ("^5tinvalid - bad BJ index^31t^i", dm_journal_segp -> dm_journal.synch_write_inv_ix);
		call ioa_ ("^5tinvalid - bad time stamp^31t^i", dm_journal_segp -> dm_journal.synch_write_inv_time);
		call ioa_ ("^5ttosses^31t^i", dm_journal_segp -> dm_journal.synch_write_tosses);
		call ioa_ ("^/Other ring zero calls");
		call ioa_ ("^5tunlink^31t^i", dm_journal_segp -> dm_journal.unlink_calls);
		call ioa_ ("^5tactivate^31t^i (^i denied)", dm_journal_segp -> dm_journal.activate_calls,
		     dm_journal_segp -> dm_journal.activate_denied);
		call ioa_ ("^5tdeactivate^31t^i", dm_journal_segp -> dm_journal.deactivate_calls);
		call ioa_ ("^5tset stamp^31t^i", dm_journal_segp -> dm_journal.set_stamp_calls);
		call ioa_ ("^5tallocate^31t^i", dm_journal_segp -> dm_journal.allocate_calls);
		call ioa_ ("^5tfree^31t^i", dm_journal_segp -> dm_journal.free_calls);
	     end;

	return;

     end PRINT_GLOBAL_METERS;

%page;

PRINT_ONE_JOURNAL:
     procedure (p_bj_status_index);

	dcl     p_bj_status_index	 fixed bin parameter;
	dcl     journal_index	 fixed bin;
	dcl     saved_journal_index	 fixed bin;
	dcl     time_stamp		 char (24);
	dcl     auth_string		 char (24);
          dcl     Temp_status_ptr        ptr;
     

/* if the status is from an inactive journal, we don't print it */

	if ^bj_status_ptr -> bj_status.system_info (p_bj_status_index).active
	then return;

/* get a pointer to the old status info */

	if Saved_bj_status_ptr = null ()
	then do;
		bj_status_n_journals = bj_status_ptr -> bj_status.n_journals;
		allocate bj_status set (Saved_bj_status_ptr);
		do journal_index = 1 to bj_status_n_journals;
		     unspec (Saved_bj_status_ptr -> bj_status.journal (journal_index)) = ""b;
		     Saved_bj_status_ptr -> bj_status.journal (journal_index).dir = "";
		     Saved_bj_status_ptr -> bj_status.journal (journal_index).entry = "";
		     Saved_bj_status_ptr -> bj_status.journal (journal_index).bj_uid =
			bj_status_ptr -> bj_status.journal (journal_index).bj_uid;
		end;
	     end;

/* search for the given journal in the saved copy - openings may have changed */

	do saved_journal_index = 1 to Saved_bj_status_ptr -> bj_status.n_journals
	     while (Saved_bj_status_ptr -> bj_status.journal (saved_journal_index).bj_uid
	     ^= bj_status_ptr -> bj_status.journal (p_bj_status_index).bj_uid);
	end;

	if saved_journal_index = Saved_bj_status_ptr -> bj_status.n_journals + 1
	then do saved_journal_index = 1 to Saved_bj_status_ptr -> bj_status.n_journals
		while (Saved_bj_status_ptr -> bj_status.journal (saved_journal_index).bj_uid ^= ""b);
	     end;



/* Create a zero saved journal entry so that we can get some sort of stats out. */

	if saved_journal_index = Saved_bj_status_ptr -> bj_status.n_journals + 1

	then do;


		bj_status_n_journals = Saved_bj_status_ptr -> bj_status.n_journals +1;
		allocate bj_status set (Temp_status_ptr);
		do journal_index = 1 to bj_status_n_journals -1;

		     Temp_status_ptr -> bj_status.journal(journal_index) = Saved_bj_status_ptr -> bj_status.journal (journal_index);
		    Temp_status_ptr -> bj_status.journal(journal_index).dir = Saved_bj_status_ptr -> bj_status.journal (journal_index).dir;
		    Temp_status_ptr -> bj_status.journal(journal_index).entry = Saved_bj_status_ptr -> bj_status.journal (journal_index).entry;
		   Temp_status_ptr -> bj_status.journal(journal_index).bj_uid =  Saved_bj_status_ptr -> bj_status.journal (journal_index).bj_uid;

		end;

		free Saved_bj_status_ptr -> bj_status;
		Saved_bj_status_ptr = Temp_status_ptr;

		unspec (Saved_bj_status_ptr -> bj_status.journal (bj_status_n_journals)) = ""b;
		Saved_bj_status_ptr -> bj_status.journal (bj_status_n_journals).dir = "";
		Saved_bj_status_ptr -> bj_status.journal (bj_status_n_journals).entry = "";
		Saved_bj_status_ptr -> bj_status.journal (journal_index).bj_uid =
		     bj_status_ptr -> bj_status.journal (journal_index).bj_uid;
	     end;


/* at this point we have found the entry in the saved meters */

	total_bi_bytes =
	     bj_status_ptr -> bj_status.n_bi_bytes_written (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_bi_bytes_written (saved_journal_index);

	total_bi_written =
	     bj_status_ptr -> bj_status.n_bi_written (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_bi_written (saved_journal_index);

	total_non_null_txns =
	     bj_status_ptr -> bj_status.n_non_null_txn (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_non_null_txn (saved_journal_index);

	total_recycles =
	     bj_status_ptr -> bj_status.n_successful_recycles (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_successful_recycles (saved_journal_index);

	total_ci_recycled =
	     bj_status_ptr -> bj_status.n_ci_recycled (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_ci_recycled (saved_journal_index);

	if total_non_null_txns = 0
	then avg_n_bytes_per_txn = 0;
	else avg_n_bytes_per_txn = total_bi_bytes / total_non_null_txns;

	if total_bi_written = 0
	then avg_n_bytes_per_bi = 0;
	else avg_n_bytes_per_bi = total_bi_bytes / total_bi_written;

	if total_non_null_txns = 0
	then avg_n_bi_per_txn = 0;
	else avg_n_bi_per_txn = total_bi_written / total_non_null_txns;

	if total_recycles = 0
	then avg_n_ci_per_recycle = 0;
	else avg_n_ci_per_recycle = total_ci_recycled / total_recycles;

	call ioa_ ("^2/^a^[>^]^a^/", bj_status_ptr -> bj_status.dir (p_bj_status_index),
	     (bj_status_ptr -> bj_status.dir (p_bj_status_index) ^= ">"),
	     bj_status_ptr -> bj_status.entry (p_bj_status_index));
	call ioa_ ("journal size^31t^i", bj_status_ptr -> bj_status.max_size (p_bj_status_index));
	call ioa_ ("before images written^31t^i", total_bi_written);
	call ioa_ ("before image bytes written^31t^i", total_bi_bytes);
	call ioa_ ("times journal filled^31t^i",
	     bj_status_ptr -> bj_status.n_journal_full (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_journal_full (saved_journal_index));
	call ioa_ ("times txn storage limit hit^31t^i",
	     bj_status_ptr -> bj_status.n_txn_storage_limit_hits (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_txn_storage_limit_hits (saved_journal_index));
	call ioa_ ("successful recycles^31t^i", total_recycles);
	call ioa_ ("control intervals recycled^31t^i", total_ci_recycled);
	call ioa_ ("transactions started^31t^i",
	     bj_status_ptr -> bj_status.n_txn_started (p_bj_status_index)
	     - Saved_bj_status_ptr -> bj_status.n_txn_started (saved_journal_index));
	call ioa_ ("non null transactions^31t^i", total_non_null_txns);
	call ioa_ ("avg before image/transaction^31t^i", avg_n_bi_per_txn);
	call ioa_ ("avg bytes/before image^31t^i", avg_n_bytes_per_bi);
	call ioa_ ("avg bytes/transaction^31t^i", avg_n_bytes_per_txn);
	call ioa_ ("avg control intervals/recycle^31t^i", avg_n_ci_per_recycle);

	if metering_regions_filled
	     then do;
	     dm_per_journalp = addr (dm_journal.per_journal (bj_status_ptr -> bj_status.journal (p_bj_status_index).bj_ix));
	     call date_time_ (dm_per_journal.time_stamp, time_stamp);
	     call convert_access_class_$to_string (dm_per_journal.access_class, auth_string, status_code);

	     call ioa_ ("time stamp^31t^a", time_stamp);
	     call ioa_ ("pages currently held^31t^i", dm_per_journal.n_held);
	     if (status_code = 0) & (auth_string ^= "")
		then call ioa_ ("authorization^31t^a", auth_string);
	end;
	
	return;

     end PRINT_ONE_JOURNAL;


/* Include Files */

%page;
%include arg_list;
%page;
%include dm_bj_status;
%page;
%include dm_bj_pst;
%page;
%include dm_bj_pste;
%page;
%include dm_journal_seg_;
%page;

     end before_journal_meters;




		    before_journal_status.pl1       04/04/85  1114.9re  04/04/85  0824.4       98253



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

/* DESCRIPTION:

   before_journal_status - command level interface to bjm_get_journal_status.
   meant to supply information about a particular journal, about all journals
   opened in the caller's process, or about all journals opened in the system.
   no attempt is made to find unused journals.

   usage:
	bjst [JNL_PATH1 ... JNL_PATHn] [-long] [-brief] [-all]
*/

/* HISTORY:
Written by M. Pandolf, 04/01/83.
Modified:
07/01/83 by M. Pandolf: to process the -all control arg and to report
            size for -bf option
12/13/84 by R. Michael Tague: Fixed DESCRIPTION AND HISTORY section, made
            variables used in internal procedure declared locally, and fixed up
            because of audit comments.
12/17/84 by R. Michael Tague: Changed to use pathname_ to display bj pathname.
	  Fixed to:  not report activity information for an inactive before
	  journal,  not  output the  unsupported "earliest_meaningful_time"
	  (time  first  record  written),  use correct  parameter  names on
	  internal  procs, correctly  calculate n_ci_used  if the journal's
	  origin  is <=  current buffered  CI, and  free the  bj_status and
	  bj_global_meters structures  if cleanup is done;  also changed to
	  use init clauses on many automatic variables.
03/20/85 by S. Cox: Added dm_not_available_ handler, and ERROR_RETURN.
03/20/85 by Lee A. Newcomb:  To output per-transaction storage limit in brief
            info.
*/

/* format: style2 */
%page;
before_journal_status:
bjst:
     procedure () options (variable);

/* DECLARATIONS */

/* Automatic */

	dcl     area_ptr		 pointer init (null);
	dcl     arg_count		 fixed bin;
	dcl     arg_len		 fixed bin (21);
	dcl     arg_no		 fixed bin;
	dcl     arg_ptr		 pointer;
	dcl     bj_dir		 char (168) init ("");
	dcl     bj_entry		 char (32) init ("");
	dcl     bj_ix		 fixed bin init (0);
	dcl     code		 fixed bin (35) init (0);
	dcl     freeing_in_progress	 bit (1) aligned init (""b);
						/* for cleanup */
	dcl     last_ci_put_time	 char (20);
	dcl     last_ci_disk_time	 char (20);
	dcl     path_count		 fixed bin init (0);
	dcl     report_format	 fixed bin init (DEFAULT_FORMAT);
	dcl     journal_group	 char (8) init (PER_PROCESS);

/* Based */

	dcl     arg		 char (arg_len) based (arg_ptr);

/* Builtin */
	dcl     null		 builtin;
	dcl     substr		 builtin;
	dcl     unspec		 builtin;

/* Condition */

	dcl     (cleanup, dm_not_available_)
				 condition;

/* Constant */

	dcl     (
	        BRIEF_FORMAT	 init (-1),
	        DEFAULT_FORMAT	 init (0),
	        LONG_FORMAT		 init (1)
	        )			 fixed bin internal static options (constant);
	dcl     MY_NAME		 char (32) internal static options (constant) init ("before_journal_status");
	dcl     NOT_DONE		 char (20) internal static options (constant) init ("not yet performed");
	dcl     (
	        PER_PROCESS		 init ("process"),
	        PER_SYSTEM		 init ("system")
	        )			 char (8) internal static options (constant);

/* Entry */

	dcl     before_journal_manager_$get_journal_status
				 entry (char (*), char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     expand_pathname_$add_suffix
				 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     get_dm_free_area_	 entry () returns (ptr);
	dcl     ioa_		 entry () options (variable);
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

/* External */

	dcl     dm_error_$system_not_initialized
				 fixed bin (35) ext static;
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;

/* END DECLARATIONS */
%page;
	on dm_not_available_
	     begin;
		call com_err_ (dm_error_$system_not_initialized, MY_NAME);
		call ERROR_RETURN;
	     end;

/* make a quick run through the arg list looking for control args */

	call cu_$arg_count (arg_count, code);
	if code ^= 0
	then do;
		call com_err_ (code, MY_NAME);
		call ERROR_RETURN;
	     end;

/* analyze the args, by validating control args and counting journal paths */

	do arg_no = 1 to arg_count;
	     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
	     if (arg = "-long") | (arg = "-lg")
	     then report_format = LONG_FORMAT;
	     else if (arg = "-brief") | (arg = "-bf")
	     then report_format = BRIEF_FORMAT;
	     else if (arg = "-all") | (arg = "-a")
	     then journal_group = PER_SYSTEM;
	     else if substr (arg, 1, 1) = "-"
	     then do;
		     call com_err_ (error_table_$bad_arg, MY_NAME, "^/The argument is ""^a"".", arg);
		     call ERROR_RETURN;
		end;
	     else path_count = path_count + 1;
	end;

/* make a second pass through the args looking for path names */

	area_ptr = get_dm_free_area_ ();
	bj_status_ptr, bj_global_meters_ptr = null ();
	on cleanup call CLEAN_UP ();

	if path_count < 1				/* user wants active journals summary */
	then do;
		call before_journal_manager_$get_journal_status ("", journal_group, area_ptr, bj_status_ptr,
		     bj_global_meters_ptr, code);
		if code ^= 0
		then do;
			call com_err_ (code, MY_NAME);
			call ERROR_RETURN;
		     end;
		else do bj_ix = 1 to bj_status.n_journals;
			call PRINT_ONE_JOURNAL (bj_ix);
		     end;
		if bj_status.n_journals = 0
		then call ioa_ ("There are no journals currently being used.");
		freeing_in_progress = "1"b;
		free bj_status_ptr -> bj_status;
		free bj_global_meters_ptr -> bj_global_meters;
		bj_status_ptr, bj_global_meters_ptr = null ();
		freeing_in_progress = ""b;
	     end;
	else do arg_no = 1 to arg_count;
		call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
		if substr (arg, 1, 1) ^= "-"
		then do;

			call expand_pathname_$add_suffix (arg, "bj", bj_dir, bj_entry, code);
			if code ^= 0
			then do;
INVALID_JOURNAL_ARG:
				call com_err_ (code, MY_NAME, "^/Supplied journal pathname is ""^a"".", arg);
				call ERROR_RETURN;
			     end;

			call before_journal_manager_$get_journal_status (bj_dir, bj_entry, area_ptr, bj_status_ptr,
			     bj_global_meters_ptr, code);
			if code ^= 0
			then goto INVALID_JOURNAL_ARG;
			else do;
				call PRINT_ONE_JOURNAL (1);
				freeing_in_progress = "1"b;
				free bj_status_ptr -> bj_status;
				free bj_global_meters_ptr -> bj_global_meters;
				bj_status_ptr, bj_global_meters_ptr = null ();
				freeing_in_progress = ""b;
			     end;

		     end;
	     end;
MAIN_RETURN:
	return;
%skip;
ERROR_RETURN:
     proc ();

	goto MAIN_RETURN;
     end;
%page;
PRINT_ONE_JOURNAL:
     procedure (poj_p_status_index);

	dcl     poj_p_status_index	 fixed bin;

	dcl     poj_index		 fixed bin;
	dcl     poj_first_record_time	 char (20);
	dcl     poj_header_update_time char (20);
	dcl     poj_n_ci_used	 fixed bin (35);


	poj_index = poj_p_status_index;

PRINT_BRIEF_INFORMATION:
	do;
	     call ioa_ ("^/pathname:^31t^a^/journal uid:^31t^12.3b^/activity:^31t^[not ^]in use",
		pathname_ ((bj_status.journal (poj_index).dir), (bj_status.journal (poj_index).entry)),
		bj_status.system_info (poj_index).bj_uid, ^bj_status.system_info (poj_index).active);

	     call ioa_ ("control interval size:^31t^i bytes^/control intervals:^31t^i",
		bj_status.system_info (poj_index).ci_size, bj_status.system_info (poj_index).max_size);
	     call ioa_ ("transaction storage limit:^31t^i bytes", bj_status.system_info (poj_index).txn_storage_limit);
	end PRINT_BRIEF_INFORMATION;


	if report_format ^= BRIEF_FORMAT & bj_status.system_info (poj_index).active
	then
PRINT_DEFAULT_INFORMATION_NEXT:
	     do;

		if bj_status.system_info (poj_index).last_ci_buffered >= bj_status.system_info (poj_index).origin_ci
		then poj_n_ci_used =
			bj_status.system_info (poj_index).last_ci_buffered
			- bj_status.system_info (poj_index).origin_ci + 1;
		else poj_n_ci_used =
			(bj_status.system_info (poj_index).highest_ci - bj_status.system_info (poj_index).origin_ci)
			+ 1 + bj_status.system_info (poj_index).last_ci_buffered;

		call ioa_ ("control intervals used:^31t^i", poj_n_ci_used);

		call ioa_ (
		     "last control interval^/^11tbuffered:^31t^i^/^11tput:^31t^i^/^11tflushed:^31t^i^/^11ton disk:^31t^i",
		     unspec (bj_status.system_info (poj_index).last_ci_buffered),
		     unspec (bj_status.system_info (poj_index).last_ci_put),
		     unspec (bj_status.system_info (poj_index).last_ci_flushed),
		     unspec (bj_status.system_info (poj_index).last_ci_on_disk));
	     end PRINT_DEFAULT_INFORMATION_NEXT;

	if report_format = LONG_FORMAT
	then
PRINT_LONG_FORMAT_INFORMATION:
	     do;

		if bj_status.system_info (poj_index).time_header_updated = 0
		then poj_header_update_time = NOT_DONE;
		else call date_time_ (bj_status.system_info (poj_index).time_header_updated, poj_header_update_time);

		if bj_status.system_info (poj_index).active
		then do;
			if bj_status.system_info (poj_index).stamp_for_last_ci_put = 0
			then last_ci_put_time = NOT_DONE;
			else call date_time_ (bj_status.system_info (poj_index).stamp_for_last_ci_put,
				last_ci_put_time);

			if bj_status.system_info (poj_index).stamp_for_last_ci_on_disk = 0
			then last_ci_disk_time = NOT_DONE;
			else call date_time_ (bj_status.system_info (poj_index).stamp_for_last_ci_on_disk,
				last_ci_disk_time);

			call ioa_ ("time last control interval^/^11tqueued:^31t^20a^/^11twritten:^31t^20a",
			     last_ci_put_time, last_ci_disk_time);
		     end;

		call ioa_ ("time header updated:^31t^20a", poj_header_update_time);
		if bj_status.system_info (poj_index).active
		then do;
			call ioa_ ("last record id:^31t^12.3b", bj_status.system_info (poj_index).last_rec_id);

			call ioa_ ("images not on disk:^31t^i^/images being flushed:^31t^i",
			     bj_status.system_info (poj_index).n_bi_still_unsafe,
			     bj_status.system_info (poj_index).n_bi_being_saved);

			call ioa_ ("users:^31t^i^/transactions:^31t^i",
			     bj_status.system_info (poj_index).n_processes, bj_status.system_info (poj_index).n_txn)
			     ;
		     end;
	     end PRINT_LONG_FORMAT_INFORMATION;

	return;

     end PRINT_ONE_JOURNAL;
%page;
CLEAN_UP:
     proc ();

/* Try to free the bj_status and bj_global_meters structures.  */
/* If the freeing_in_progress indicator is on, then we do      */
/* nothing so as to not attempt a double free.		   */

	if ^freeing_in_progress
	then do;
		if bj_status_ptr ^= null ()
		then free bj_status;
		if bj_global_meters_ptr ^= null ()
		then free bj_global_meters;
	     end;

     end CLEAN_UP;
%page;
%include dm_bj_status;
%page;
%include dm_bj_pst;
%page;
%include dm_bj_pste;


     end before_journal_status;




		    bj_mgr_call.pl1                 04/04/85  1114.9re  04/04/85  0824.5      243090



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

/* DESCRIPTION
   bj_mgr_call - command/active function interface to selected
   before_journal_manager_ entrypoints.

   Usage:
	bjmc OPERATION {ARGS}
   where:
	OPERATION can be create, open, close, opened, closed,
	set_default_journal, or get_default_journal.

	ARGS are specific for each operation.
*/

/* HISTORY:
Written by M. Pandolf, 12/??/83.
Modified:
10/22/84 by M.Sharpe:  to correct format, to correct calling sequence
	  to any_err_, to pass standard error codes to com_err_.
03/19/85 by Lindsey L. Spratt:  Added the -transaction_storage_limit (-tsl)
            option to the create operation.  Added the
            set_transaction_storage_limit operation.
03/20/85 by Lindsey L. Spratt:  Added a dm_not_available_ handler.
03/26/85 by Lindsey Spratt:  Fixed the syntax for the stsl keyword so that the
	  transaction storage limit must be specified via
	  -transaction_storage_limit (-tsl).
03/27/85 by Lee A. Newcomb:  Renamed the set_transaction_storage_limit
            operation to set_attribute as per the amended MCR7217.
*/

/* format: style2,ind3 */
%page;
bj_mgr_call:
bjmc:
   procedure () options (variable);

/* DECLARATIONS */

/* Automatic */

      dcl	    a_path	       fixed bin;
      dcl	    arg_list_ptr	       pointer;
      dcl	    argl		       fixed bin (21);
      dcl	    argno		       fixed bin;
      dcl	    argp		       pointer;
      dcl	    bj_ci_no	       fixed bin;
      dcl	    bj_ci_size	       fixed bin;
      dcl	    bj_oid	       bit (36) aligned;
      dcl	    code		       fixed bin (35);
      dcl	    creation_looks_reasonable
			       bit (1) aligned;
      dcl	    i_am_an_active_function
			       bit (1) aligned;
      dcl	    nargs		       fixed bin;
      dcl	    rsp		       pointer;
      dcl	    rsl		       fixed bin (21);
      dcl	    transaction_storage_limit
			       fixed bin (35) init (UNSET_STORAGE_LIMIT);

/* Based */

      dcl	    arg		       char (argl) based (argp);
      dcl	    return_string	       char (rsl) varying based (rsp);

/* Builtin */

      dcl	    substr	       builtin;

/* Entry */

      dcl	    active_fnc_err_	       entry options (variable);
      dcl	    any_err_	       entry () variable options (variable);
      dcl	    before_journal_manager_$open_bj
			       entry (char (*), char (*), bit (36) aligned, fixed bin (35));
      dcl	    before_journal_manager_$create_bj
			       entry (char (*), char (*), fixed bin, fixed bin, fixed bin (35));
      dcl	    before_journal_manager_$close_bj
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    before_journal_manager_$delete_bj
			       entry (char (*), char (*), fixed bin (35));
      dcl	    before_journal_manager_$get_default_bj
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    before_journal_manager_$set_default_bj
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    before_journal_manager_$get_bj_path_from_oid
			       entry (bit (36) aligned, char (*), char (*), fixed bin (35));
      dcl	    before_journal_manager_$get_bj_oid
			       entry (char (*), char (*), bit (36) aligned, fixed bin (35));
      dcl	    before_journal_manager_$set_transaction_storage_limit
			       entry (char (*), char (*), fixed bin (35), fixed bin (35));

      dcl	    check_star_name_$entry entry (char (*), fixed bin (35));
      dcl	    com_err_	       entry () options (variable);
      dcl	    cu_$af_return_arg      entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
      dcl	    cu_$arg_count_rel      entry (fixed bin, ptr, fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    cv_dec_check_	       entry (char (*), fixed bin (35)) returns (fixed bin (35));
      dcl	    expand_pathname_$add_suffix
			       entry (char (*), char (*), char (*), char (*), fixed bin (35));
      dcl	    ioa_		       entry () options (variable);
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    ioa_$rsnnl	       entry () options (variable);
      dcl	    nd_handler_	       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));

/* External Static */

      dcl	    dm_error_$bj_journal_not_opened
			       fixed bin (35) ext static;
      dcl	    dm_error_$file_already_exists
			       fixed bin (35) ext static;
      dcl	    dm_error_$system_not_initialized
			       fixed bin (35) ext static;
      dcl	    error_table_$not_act_fnc
			       fixed bin (35) ext static;
      dcl	    error_table_$active_function
			       fixed bin (35) ext static;
      dcl	    error_table_$bad_arg   fixed bin (35) ext static;
      dcl	    error_table_$badcall   fixed bin (35) ext static;
      dcl	    error_table_$noarg     fixed bin (35) ext static;
      dcl	    error_table_$nostars   fixed bin (35) ext static;
      dcl	    error_table_$action_not_performed
			       fixed bin (35) ext static;
      dcl	    error_table_$notadir   fixed bin (35) ext static;

/* Condition */

      dcl	    dm_not_available_      condition;

/* Constant */

      dcl	    UNSET_STORAGE_LIMIT    init (-1) fixed bin (35) internal static options (constant);
      dcl	    ME		       char (32) internal static options (constant) init ("bj_mgr_call");
      dcl	    DEFAULT_BJ_CI_NO       fixed bin internal static options (constant) init (64);
      dcl	    DEFAULT_BJ_CI_SIZE     fixed bin internal static options (constant) init (4096);
      dcl	    (
	    NO_PAD	       init ("0"b),
	    NO_NL		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);

/* END OF DECLARATIONS */

/* how were we called? */

      call cu_$af_return_arg (nargs, rsp, rsl, code);
      if code = error_table_$not_act_fnc
      then
         do;					/* COMMAND call */
	  i_am_an_active_function = "0"b;
	  any_err_ = com_err_;
         end;
      else if code ^= 0
      then
         do;					/* faulty call */
	  call com_err_ (code, ME);
	  return;
         end;
      else
         do;					/* AF call */
	  i_am_an_active_function = "1"b;
	  any_err_ = active_fnc_err_;
         end;

/* is the operation specified? */

      if nargs = 0
      then
         do;
	  call any_err_ (error_table_$noarg, ME, "^/Usage is: bjmc OPERATION {ARGS}.");
	  return;
         end;

      call cu_$arg_list_ptr (arg_list_ptr);		/* needed by the following begin block */
%page;
/* the following begin block contains the list of before journal pathnames */

the_real_work:
      begin;

         dcl     bj_dir		dim (nargs) char (168),
	       bj_entry		dim (nargs) char (32),
	       path_count		fixed bin;

/* initialize our automatic */

         bj_dir (*) = "";
         bj_entry (*) = "";
         path_count = 0;

         on dm_not_available_ call ERROR_RETURN (dm_error_$system_not_initialized);


/* figure out why we're here */

         call cu_$arg_ptr_rel (1, argp, argl, code, arg_list_ptr);

         if arg = "create" | arg = "cr"
         then call CREATE ();
         else if arg = "open" | arg = "o"
         then call OPEN ();
         else if arg = "close" | arg = "cl"
         then call CLOSE ();
         else if arg = "opened"
         then call OPENED ();
         else if arg = "closed"
         then call CLOSED ();
         else if arg = "set_default_journal" | arg = "sdp"
         then call SET_DEFAULT_PATH ();
         else if arg = "get_default_journal" | arg = "gdp"
         then call GET_DEFAULT_PATH ();
         else if arg = "set_attribute" | arg = "sattr"
         then call SET_ATTRIBUTE ();
         else call ERROR_RETURN (error_table_$bad_arg, "^a.^/Allowed operations are: create, open, close, opened, closed,
    set_default_journal, get_default_journal, set_transaction_storage_limit.", arg);
MAIN_RETURN:
         return;

/* end of begin block's processing. internal support procedures follow */


/* INTERNAL PROCEDURES */
%page;
ERROR_RETURN:
   proc () options (variable);
      dcl	    er_p_code_ptr	       ptr init (null ());
      dcl	    er_p_code	       based (er_p_code_ptr) fixed bin (35);
      dcl	    er_arg_list_ptr	       ptr init (null);
      dcl	    er_code	       fixed bin (35);
      dcl	    er_msg	       char (1024);
      dcl	    er_based_msg	       char (er_msg_length) based (addr (er_msg));
      dcl	    er_msg_length	       fixed bin (21) init (0);

      dcl	    er_nargs	       fixed bin;

      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_count_rel (er_nargs, er_arg_list_ptr, (0));
      if er_nargs = 0
      then er_code = 0;
      else
         do;
	  call cu_$arg_ptr_rel (1, er_p_code_ptr, (0), (0), er_arg_list_ptr);
	  er_code = er_p_code;
         end;
      if er_nargs >= 2
      then call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_msg, er_msg_length, NO_PAD, NO_NL);

      call any_err_ (er_code, ME, "^a", er_based_msg);
      goto MAIN_RETURN;

   end ERROR_RETURN;
%page;
CREATE:
   procedure ();

      if i_am_an_active_function
      then return_string = "true";

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg,
	      "^/Usage is:  bjmc create JOURNAL_PATH {-length NUMBER_OF_CI|-transaction_storage_limit N_BYTES}");

/* set defaults */

      bj_ci_no = DEFAULT_BJ_CI_NO;
      bj_ci_size = DEFAULT_BJ_CI_SIZE;

/* process the args */

      argno = 2;
processing_of_create_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-length" | arg = "-ln"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-length"" requires a number (of control intervals).");

	     bj_ci_no = cv_dec_check_ (arg, code);

	     if code ^= 0
	     then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is not numeric.", arg);

	  end;
         else if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if arg = "-transaction_storage_limit" | arg = "-tsl"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code,
		     "^/""-transaction_storage_limit"" requires an argument specifying the number^/of bytes for the limit."
		     );

	     transaction_storage_limit = cv_dec_check_ (arg, code);
	     if code ^= 0
	     then call ERROR_RETURN (error_table_$bad_arg,
		     "^/Unable to convert ^a to the number of bytes for the^/transaction storage limit.", arg);
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);

         else call GET_PATH_FROM_ARG ();

         argno = argno + 1;
      end processing_of_create_args;

/* anything to create? */

      if path_count = 0				/* nope... */
      then call ERROR_RETURN (error_table_$noarg, "^/The name of a journal is required.");


/* create the before journals */

creating_the_journals:
      do a_path = 1 to path_count while (code = 0);
         creation_looks_reasonable = "1"b;
creating_one_journal:
         do while (creation_looks_reasonable);
	  call before_journal_manager_$create_bj (bj_dir (a_path), bj_entry (a_path), bj_ci_no, bj_ci_size, code);
	  if code = dm_error_$file_already_exists | code = error_table_$notadir
	  then
	     do;
	        call nd_handler_ (ME, bj_dir (a_path), bj_entry (a_path), code);
	        if code ^= 0
	        then creation_looks_reasonable = "0"b;
	        if code = error_table_$action_not_performed
	        then code = 0;
	     end;
	  else creation_looks_reasonable = "0"b;
         end creating_one_journal;

         if code ^= 0
         then if i_am_an_active_function
	    then return_string = "false";
	    else call any_err_ (code, ME, "^/Creating ^a.", pathname_ (bj_dir (a_path), bj_entry (a_path)));
         else if transaction_storage_limit ^= UNSET_STORAGE_LIMIT
         then
	  do;
	     call before_journal_manager_$set_transaction_storage_limit (bj_dir (a_path), bj_entry (a_path),
		transaction_storage_limit, code);
	     if code ^= 0
	     then call any_err_ (code, ME, "^/Unable to set the transaction_storage_limit for ^a.",
		     pathname_ (bj_dir (a_path), bj_entry (a_path)));
	  end;

      end creating_the_journals;

/* finished with the create operation */

      return;

   end CREATE;
%page;
OPEN:
   procedure ();

      if i_am_an_active_function
      then return_string = "true";

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg, "^/Usage is:  bjmc open JOURNAL_PATHS");


/* process the args */

      argno = 2;
processing_of_open_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);
         else call GET_PATH_FROM_ARG ();
         argno = argno + 1;
      end processing_of_open_args;

/* anything to open? */

      if path_count = 0
      then call ERROR_RETURN (error_table_$noarg, "^/The name of a journal is required.");

/* open the before journals */

opening_the_journals:
      do a_path = 1 to path_count;
         call before_journal_manager_$open_bj (bj_dir (a_path), bj_entry (a_path), bj_oid, code);
         if code ^= 0
         then if i_am_an_active_function
	    then return_string = "false";
	    else call any_err_ (code, ME, "^/Attempting to open journal ^a.",
		    pathname_ (bj_dir (a_path), bj_entry (a_path)));
      end opening_the_journals;

/* finished with the open operation */

      return;
   end OPEN;
%page;
CLOSE:
   procedure ();

      if i_am_an_active_function
      then return_string = "true";

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg, "^/Usage is:  bjmc close JOURNAL_PATHS");

/* process the args */

      argno = 2;
processing_of_close_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);
         else call GET_PATH_FROM_ARG ();
         argno = argno + 1;
      end processing_of_close_args;

/* anything to close? */

      if path_count = 0
      then call ERROR_RETURN (error_table_$noarg, "^/The name of a journal is required.");

/* close the before journals */

closing_the_journals:
      do a_path = 1 to path_count;
         call before_journal_manager_$get_bj_oid (bj_dir (a_path), bj_entry (a_path), bj_oid, code);
         if code ^= 0
         then call any_err_ (code, ME, "^/Attempting to close journal ^a.",
	         pathname_ (bj_dir (a_path), bj_entry (a_path)));
         else
	  do;
	     call before_journal_manager_$close_bj (bj_oid, code);
	     if code ^= 0
	     then if i_am_an_active_function
		then return_string = "false";
		else call any_err_ (code, ME, "^/Attempting to close journal ^a.",
			pathname_ (bj_dir (a_path), bj_entry (a_path)));
	  end;
      end closing_the_journals;

/* finished with the close operation */

      return;

   end CLOSE;
%page;
OPENED:
   procedure ();

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg, "^/Usage is:  ^[[^]bjmc opened JOURNAL_PATHS^[]^]",
	      i_am_an_active_function, i_am_an_active_function);

/* process the args */

      argno = 2;
processing_of_opened_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);
         else call GET_PATH_FROM_ARG ();
         argno = argno + 1;
      end processing_of_opened_args;

/* allow only one query */

      if path_count ^= 1
      then call ERROR_RETURN (error_table_$badcall, "Usage is: ^[[^]bjmc opened JOURNAL_PATH^[]^]",
	      i_am_an_active_function, i_am_an_active_function);

/* check the before journal */

      call before_journal_manager_$get_bj_oid (bj_dir (1), bj_entry (1), bj_oid, code);

      if i_am_an_active_function
      then if code = 0
	 then return_string = "true";
	 else if code = dm_error_$bj_journal_not_opened
	 then return_string = "false";
	 else call ERROR_RETURN (code, "^/Referencing ^a.", pathname_ (bj_dir (1), bj_entry (1)));
      else if code = 0
      then call ioa_ ("true");
      else if code = dm_error_$bj_journal_not_opened
      then call ioa_ ("false");
      else call ERROR_RETURN (code, "^/Referencing ^a.", pathname_ (bj_dir (1), bj_entry (1)));


/* finished with the opened operation */

      return;

   end OPENED;
%page;
CLOSED:
   procedure ();

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg, "^/Usage is:  ^[[^]bjmc closed JOURNAL_PATHS^[]^]",
	      i_am_an_active_function, i_am_an_active_function);

/* process the args */

      argno = 2;
processing_of_closed_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);
         else call GET_PATH_FROM_ARG ();
         argno = argno + 1;
      end processing_of_closed_args;

/* allow only one query */

      if path_count ^= 1
      then call ERROR_RETURN (error_table_$badcall, "Usage is: ^[[^]bjmc closed JOURNAL_PATH^[]^]",
	      i_am_an_active_function, i_am_an_active_function);

/* check the before journal */

      call before_journal_manager_$get_bj_oid (bj_dir (1), bj_entry (1), bj_oid, code);

      if i_am_an_active_function
      then if code = 0
	 then return_string = "false";
	 else if code = dm_error_$bj_journal_not_opened
	 then return_string = "true";
	 else call ERROR_RETURN (code, "^/Referencing ^a.", pathname_ (bj_dir (1), bj_entry (1)));
      else if code = 0
      then call ioa_ ("false");
      else if code = dm_error_$bj_journal_not_opened
      then call ioa_ ("true");
      else call ERROR_RETURN (code, "^/Referencing ^a.", pathname_ (bj_dir (1), bj_entry (1)));


/* finished with the closed operation */

      return;

   end CLOSED;
%page;
SET_DEFAULT_PATH:
   procedure ();

      if i_am_an_active_function
      then return_string = "true";

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg, "^/Usage is:  bjmc set_default_journal JOURNAL_PATH");

/* process the args */

      argno = 2;
processing_of_set_default_path_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);
         else call GET_PATH_FROM_ARG ();
         argno = argno + 1;
      end processing_of_set_default_path_args;

/* allow only one query */

      if path_count ^= 1
      then call ERROR_RETURN (error_table_$badcall, "Usage is: bjmc set_default_journal JOURNAL_PATH");

/* see that the journal is opened */

      call before_journal_manager_$get_bj_oid (bj_dir (1), bj_entry (1), bj_oid, code);
      if code ^= 0
      then call ERROR_RETURN (code, "^/Unable to set default before journal path to ^a.",
	      pathname_ (bj_dir (1), bj_entry (1)));

/* set the default path */

      call before_journal_manager_$set_default_bj (bj_oid, code);
      if code ^= 0
      then if i_am_an_active_function
	 then return_string = "false";
	 else call ERROR_RETURN (code, "^/Unable to set default before journal path to ^a.",
		 pathname_ (bj_dir (1), bj_entry (1)));

      return;

   end SET_DEFAULT_PATH;
%page;
GET_DEFAULT_PATH:
   procedure ();

      if nargs > 1
      then call ERROR_RETURN (error_table_$badcall, "Usage is: ^[[^]bjmc get_default_journal^[]^]",
	      i_am_an_active_function, i_am_an_active_function);

/* get the bj_oid that is the default at this moment */

      call before_journal_manager_$get_default_bj (bj_oid, code);
      if code ^= 0
      then call ERROR_RETURN (code);

/* the bj_oid does very little for the user... give the pathname */

      call before_journal_manager_$get_bj_path_from_oid (bj_oid, bj_dir (1), bj_entry (1), code);

      if i_am_an_active_function
      then if code = 0
	 then call ioa_$rsnnl ("^a", return_string, rsl, pathname_ (bj_dir (1), bj_entry (1)));
	 else call ERROR_RETURN (code);
      else if code = 0
      then call ioa_ ("^a", pathname_ (bj_dir (1), bj_entry (1)));
      else call ERROR_RETURN (code);

      return;

   end GET_DEFAULT_PATH;
%page;
SET_ATTRIBUTE:
   procedure ();

      if i_am_an_active_function
      then return_string = "true";

      if nargs = 1
      then call ERROR_RETURN (error_table_$noarg, "^/Usage is:  bjmc sattr JOURNAL_PATHS -control_arg");

/* process the args */

      argno = 2;
processing_of_set_attribute_args:
      do while (argno <= nargs);

         call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);

         if argl = 0
         then call ERROR_RETURN (error_table_$bad_arg, "Null argument found in argument list.");

         if arg = "-pathname" | arg = "-pn"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-pathname"" requires a path name.");

	     call GET_PATH_FROM_ARG ();
	  end;
         else if arg = "-transaction_storage_limit" | arg = "-tsl"
         then
	  do;
	     argno = argno + 1;
	     call cu_$arg_ptr_rel (argno, argp, argl, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/""-transaction_storage_limit"" requires an integer argument.");
	     transaction_storage_limit = cv_dec_check_ (arg, code);
	     if code ^= 0
	     then call ERROR_RETURN (error_table_$bad_arg,
		     "^/Unable to convert the transaction storage limit ^a into an integer.", arg);
	  end;
         else if substr (arg, 1, 1) = "-"
         then call ERROR_RETURN (error_table_$bad_arg, "^/""^a"" is an unrecognized argument.", arg);
         else call GET_PATH_FROM_ARG ();

         argno = argno + 1;

      end processing_of_set_attribute_args;

      if transaction_storage_limit = UNSET_STORAGE_LIMIT
      then call ERROR_RETURN (error_table_$noarg, "^/A transaction storage limit must be specified.");

/* anything to sattr? */

      if path_count = 0
      then call ERROR_RETURN (error_table_$noarg, "^/The name of a journal is required.");


/* set the attriubtes of the journals: curr. only transaction storage	*/
/* limit is settable.					*/
setting_the_journals:
      do a_path = 1 to path_count;
         call before_journal_manager_$set_transaction_storage_limit (bj_dir (a_path), bj_entry (a_path),
	    transaction_storage_limit, code);
         if code ^= 0
         then if i_am_an_active_function
	    then return_string = "false";
	    else call any_err_ (code, ME, "^/Unable to set the transaction_storage_limit to ^d on journal ^a.",
		    transaction_storage_limit, pathname_ (bj_dir (a_path), bj_entry (a_path)));

      end setting_the_journals;

/* finished with the sattr operation */

      return;

   end SET_ATTRIBUTE;
%page;
GET_PATH_FROM_ARG:
   procedure ();

      dcl	    dir_name	       char (168);
      dcl	    entry_name	       char (32);

      call expand_pathname_$add_suffix (arg, "bj", dir_name, entry_name, code);
      if code ^= 0
      then call ERROR_RETURN (code, "^/Unable to expand the pathname ""^a"".", arg);

      call check_star_name_$entry (entry_name, code);
      if code = 1 | code = 2
      then code = error_table_$nostars;
      if code ^= 0
      then call ERROR_RETURN (code, "^/Failed the starname check on the entry name ""^a"".", entry_name);

      path_count = path_count + 1;
      bj_dir (path_count) = dir_name;
      bj_entry (path_count) = entry_name;

      return;

   end GET_PATH_FROM_ARG;

      end the_real_work;


   end bj_mgr_call;




		    bj_suffix_info_.cds             04/04/85  1114.9re  04/04/85  0824.5       24687



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

/* DESCRIPTION:
   bj_suffix_info_ - a constant structure to be used by suffix_bj_$suffix_info
   so that the overhead of assigning 10 or more variables at each invocation
   can be avoided.
*/

/* HISTORY:
Written by M. Pandolf, 11/02/83
Modified:
12/11/84 by M.Sharpe:  to correct format.
*/
/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;

bj_suffix_info_:
	procedure ();

/* DECLARATIONS */

/* Automatic */

dcl  (
      code			fixed bin (35),
      1 local_cds_args		aligned like cds_args,
      1 bj_suffix_info		aligned like suffix_info
     )				automatic;

/* Constant */

dcl  (
      EXCLUDE_ARRAY			dim (1) char (32) init ("pad*"),
      MYNAME			char (32) init ("bj_suffix_info_")
     )				internal static options (constant);

/* Entry */

dcl  com_err_			entry() options(variable),
     create_data_segment_		entry (ptr, fixed bin(35));

/* Builtin */

dcl  (addr, hbound, size, unspec)	builtin;

%page;

	bj_suffix_info.version = SUFFIX_INFO_VERSION_1;
	bj_suffix_info.type = "bj";
	bj_suffix_info.type_name = "before journal";
	bj_suffix_info.plural_name = "before journals";
	bj_suffix_info.flags.standard_object = "0"b;
	bj_suffix_info.flags.extended_acl = "0"b;
	bj_suffix_info.flags.has_switches = "0"b;
	bj_suffix_info.flags.mbz1 = ""b;
	bj_suffix_info.modes = "r w";
	bj_suffix_info.max_mode_len = 0;
	bj_suffix_info.num_ring_brackets = 0;
	string (bj_suffix_info.copy_flags) = ""b;
	bj_suffix_info.copy_flags.names = "1"b;
	bj_suffix_info.copy_flags.acl = "1"b;
	bj_suffix_info.copy_flags.max_length = "0"b;
	bj_suffix_info.copy_flags.safety_switch = "0"b;

	bj_suffix_info.info_pathname = "";

/* initialize the cds structure */

	unspec (local_cds_args) = ""b;
	local_cds_args.sections (1).p = addr (bj_suffix_info);
	local_cds_args.sections (1).len = size (bj_suffix_info);
	local_cds_args.sections (1).struct_name = "bj_suffix_info";
	local_cds_args.seg_name = MYNAME;
	local_cds_args.exclude_array_ptr = addr (EXCLUDE_ARRAY);
	local_cds_args.num_exclude_names = hbound (EXCLUDE_ARRAY, 1);
	local_cds_args.switches.have_text = "1"b;

/* call cds to make the segment */

	call create_data_segment_ (addr (local_cds_args), code);
	if code ^= 0
	then call com_err_ (code, MYNAME);

	return;

/* Include Files */

%page;
%include cds_args;
%page;
%include suffix_info;
%page;
%include copy_flags;

end bj_suffix_info_;




		    bjm_attribute_.pl1              03/06/85  0759.2re  03/05/85  0755.8       86238



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

/* DESCRIPTION:

         This is the target module for most of the calls done by the extended
     objects software for before journals.  We simply set the validation level
     to the DM ring, forward the call to file_manager_, and reset the
     validation level.  The one operation not here is delentry_file which
     suffix_bj_ directly transfers to before_journal_manager_.

	The following are the operations in this module:

	$add_acl_entries	$get_user_access_modes	$replace_acl
	$chname_file	$list_acl			$validate
	$delete_acl_entries

     NOTES:

     1) In all the entrypoints except $validate, we simply pass the parameters
     on to file_manager_ without using them; in $validate we actually use the
     input parameters so must copy them and pass the copies to file_manager_.

     2) We do not currently prevent a user from deleting the Data_Management
     Daemon's access to a before journal, nor prevent the setting of write
     only access to any user.  If this becomes a problem, then it may can be
     changed; but probably should be done in conjunction with a change to
     file_manager_ to protect against users deleting Daemon access from
     protected files (which will probably require setting off the per-process
     init first-reference trap).
*/

/* HISTORY:

Written by Lee A. Newcomb, 12/13/84.
Modified:
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;
bjm_attribute_$add_acl_entries:
   proc (p_directory_name, p_entry_name, p_acl_ptr, p_code);


/* START OF DECLARATIONS */

/* Parameter */
dcl  (
     p_acl_ptr			ptr,
     p_code			fixed bin (35),
     p_directory_name		char (*),
     p_entry_name			char (*),
     p_exmodes			bit (36) aligned,
     p_modes			bit (36) aligned,
     p_new_name			char (*),
     p_no_sysdaemon			bit (1),
     p_old_name			char (*),
     p_ring			fixed bin,
     p_user_area_ptr		ptr,
     p_user_name			char (*),
     p_version_wanted		char (*)
     )				parameter;

/* Automatic */
dcl  (
     callers_validation_level		fixed bin init (-1),/* init -1 for RETURN */
     code				fixed bin (35) init (0),
     dirname			char (168) init (""),
     ename			char (32) init (""),
     new_name			char (32) init (""),
     old_name			char (32) init (""),
     dm_ring			fixed bin init (-1),
     ring_brackets			dim (2) fixed bin (3) init (-1, -1)
     )				automatic;

/* Based */
/* Builtin */
dcl  (length, reverse, rtrim, substr)	builtin;

/* Condition */
dcl  cleanup			condition;

/* Constant */
/* Entry */
dcl  (
     cu_$level_get			entry (fixed bin),
     cu_$level_set			entry (fixed bin),
     file_manager_$add_acl_entries	entry (char (*), char (*), ptr,
				fixed bin (35)),
     file_manager_$chname_file	entry (char (*), char (*), char (*),
				char (*), fixed bin (35)),
     file_manager_$delete_acl_entries	entry (char (*), char (*), ptr,
				fixed bin (35)),
     file_manager_$get_ring_brackets	entry (char (*), char (*),
				dim (2) fixed bin (3), fixed bin (35)),
     file_manager_$get_user_access_modes
				entry (char (*), char (*), char (*),
				fixed bin, bit (36) aligned,
				bit (36) aligned, fixed bin (35)),
     file_manager_$list_acl		entry (char (*), char (*), char (*),
				ptr, ptr, fixed bin (35)),
     file_manager_$replace_acl	entry (char (*), char (*), ptr, bit,
				fixed bin (35)),
     file_manager_$validate		entry (char (*), char (*),
				fixed bin (35)),
     get_ring_			entry () returns (fixed bin (3))
     )				external;

/* External */
dcl  (
     dm_error_$bj_invalid_name	fixed bin (35),
     error_table_$not_seg_type	fixed bin (35),
     error_table_$unsupported_operation fixed bin (35)
     )				external static;

/* END OF DECLARATIONS */
%page;
/* repeat main procedure statement for reader's convenience:	*/
/*							*/
/* bjm_attribute_$add_acl_entries:				*/
/*     proc (p_directory_name, p_entry_name, p_acl_ptr, p_code);	*/

   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   call cu_$level_set (get_ring_ ());

   call file_manager_$add_acl_entries (p_directory_name, p_entry_name,
        p_acl_ptr, code);

   call RETURN (code);

/* end bjm_attribute_$add_acl_entries; */




bjm_attribute_$chname_file:
   entry (p_directory_name, p_entry_name, p_old_name, p_new_name, p_code);

/* must copy old and new name parameters as we read >1 times. */
   old_name = p_old_name;
   new_name = p_new_name;

/* currently we do not allow name deletion; this requires	*/
/* synchronizing the BJ_PST.				*/
   if old_name ^= "" then
      call RETURN (error_table_$unsupported_operation);

/* make sure the .bj suffix is on the new entryname */
   if length (rtrim (new_name)) = 0 then		/* can't delete a name */
      call RETURN (error_table_$unsupported_operation);
   if length (rtrim (new_name)) <= 3 then		/* prevent string range cond. */
      call RETURN (dm_error_$bj_invalid_name);
   if substr (reverse (rtrim (new_name)), 1, 3) ^= "jb." then
      call RETURN (dm_error_$bj_invalid_name);

   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   call cu_$level_set (get_ring_ ());

   call file_manager_$chname_file (p_directory_name, p_entry_name, old_name,
        new_name, code);

   call RETURN (code);

/* end bjm_attribute_$chname_file; */




bjm_attribute_$delete_acl_entries:
   entry (p_directory_name, p_entry_name, p_acl_ptr, p_code);

   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   call cu_$level_set (get_ring_ ());

   call file_manager_$delete_acl_entries (p_directory_name, p_entry_name,
        p_acl_ptr, code);

   call RETURN (code);

/* end bjm_attribute_$delete_acl_entries; */
%page;
bjm_attribute_$get_user_access_modes:
   entry (p_directory_name, p_entry_name, p_user_name, p_ring, p_modes,
        p_exmodes, p_code);

/* note we ignore the given p_ring and use the current	*/
/* ring of execution (the process' DM ring, normally	*/
/* sys_info$data_management_ringno unless testing).	*/
/* This is because before journals are DM files with RB's	*/
/* of 2,2 and we have no other RB's on BJ's.		*/

   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   call cu_$level_set (get_ring_ ());

   call file_manager_$get_user_access_modes (p_directory_name, p_entry_name,
        p_user_name, get_ring_ (), p_modes, p_exmodes, code);

   call RETURN (code);

/* end bjm_attribute_$get_user_access_modes */




bjm_attribute_$list_acl:
   entry (p_directory_name, p_entry_name, p_version_wanted, p_user_area_ptr,
        p_acl_ptr, p_code);


   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   call cu_$level_set (get_ring_ ());

   call file_manager_$list_acl (p_directory_name, p_entry_name,
        p_version_wanted, p_user_area_ptr, p_acl_ptr, code);

   call RETURN (code);

/* end bjm_attribute_$list_acl */




bjm_attribute_$replace_acl:
   entry (p_directory_name, p_entry_name, p_acl_ptr, p_no_sysdaemon, p_code);


   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   call cu_$level_set (get_ring_ ());

   call file_manager_$replace_acl (p_directory_name, p_entry_name, p_acl_ptr,
        p_no_sysdaemon, code);

   call RETURN (code);

/* end bjm_attribute_$replace_acl; */
%page;
bjm_attribute_$validate:
   entry (p_directory_name, p_entry_name, p_code);

/* Note:  we first call file_manager_$validate as before journals are	*/
/* unprotected DM files.  If file_manager_ returns an error, we	*/
/* simply return its returned code.  If not, we then check the ring	*/
/* brackets of the file to make sure they are {DM ring, DM ring}, if	*/
/* not, we return error_table_$not_seg_type since this is the code	*/
/* the extended object software expects if the file is not a BJ.	*/

/* must copy parameters as we will use them >1 times */
   dirname = p_directory_name;
   ename = p_entry_name;

   call cu_$level_get (callers_validation_level);
   on cleanup call cu_$level_set (callers_validation_level);
   dm_ring = get_ring_ ();
   call cu_$level_set (dm_ring);

   call file_manager_$validate (dirname, ename, code);
   if code ^= 0 then
      call RETURN (code);				/* just pass code back, fm_ has set it properly */

   call file_manager_$get_ring_brackets (dirname, ename, ring_brackets, code);
   if code ^= 0 then
      call RETURN (error_table_$not_seg_type);

   if ring_brackets (1) ^= dm_ring | ring_brackets (2) ^= dm_ring then
      call RETURN (error_table_$not_seg_type);

   call RETURN (0);					/* must be a BJ */

/* end bjm_attribute_$validate; */
%page;
MAIN_RETURN:
   return;


RETURN:
   proc (r_p_code);

/* proc to centralize returning to caller for all external entries	*/
/* and to reset the validation level to that of the caller.		*/

dcl  r_p_code			fixed bin (35);

   if callers_validation_level > 0 then
      call cu_$level_set (callers_validation_level);

   p_code = r_p_code;				/* tell caller if all is well */

   go to MAIN_RETURN;

   end RETURN;


   end bjm_attribute_$add_acl_entries;




		    bjm_no_firstref_tv_.alm         03/06/85  0759.3re  03/05/85  0755.8       13662



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"  DESCRIPTION:
"
"	  This is one of the two Data Management before journal manager
"     DM ring transfer vectors.  This one, bjm_no_firstref_tv_, is for each
"     before journal manager entry which does not require Data Management
"     per-process initialization to have been executed at some time before
"     the before journal manager entry itself is executed.  Entries which
"     require Data Management per-process initialization go through
"     bjm_firstref_tv_, which has a first reference trap which runs
"     per-process initialization the first time bjm_firstref_tv_ is
"     invoked.
"
" HISTORY:
"
" Written by Lee A. Newcomb, 12/14/84.
" Modified:
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	name	bjm_no_firstref_tv_

	macro	transfer
	entry	&1
&1:
	tra	&2

	&end


	transfer	add_acl_entries,bjm_attribute_$add_acl_entries
	transfer	chname_file,bjm_attribute_$chname_file
	transfer	delete_acl_entries,bjm_attribute_$delete_acl_entries
	transfer	get_user_access_modes,bjm_attribute_$get_user_access_modes
	transfer	list_acl,bjm_attribute_$list_acl
	transfer	replace_acl,bjm_attribute_$replace_acl
          transfer	validate,bjm_attribute_$validate

	end




		    bjm_per_system_init_1_.pl1      04/04/85  1114.9r w 04/04/85  0915.9       44514



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

/* DESCRIPTION:

     This is the part one initialization for the before journal manager.
It is responsible for creating the objects needed to run a Data Management
System.  This currently means the bj_pst and bj_txt.  This part of
initialization assumes that no running DMS support exists; i.e.
transaction_manager_ may not be relied upon, only calls to basic data
management support routines (e.g. dm_per_system_).

*/

/* HISTORY:

Written by M. Pandolf, 07/10/82.
Modified:
08/31/82 by M. Pandolf: to split into two parts
02/14/83 by M. Pandolf: to set version for TXT
08/06/83 by Lee A. Newcomb: removed obsolete code arg. from calls
	  to dm_per_system_ entries.
09/07/83 by L. A. Newcomb:  split part one and two into two distinct programs.
	  This helps maintenance and binding.  History comments for part two
	  BJM initialization have been removed.
11/19/84 by Maggie Sharpe:  to clean up format and dcls.
*/

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

%page;

bjm_per_system_init_1_:
     procedure (p_code);

/* DECLARATIONS */

/* Parameter */

dcl  p_code		        fixed bin (35)	/* standard system status code */
			        parameter;

/* Automatics */

dcl  1 default_before_journal_default_acl		/* used to set default BJ ACL */
			        dim (1) aligned automatic,
       2 access_name	        char (32) init ("*.*.*"),
       2 modes		        bit (36) init ("500000000000"b3),
       2 mbz		        bit (36) init ("000000000000"b3),
       2 status_code	        fixed bin (35) init (0);

/* External Static:  Status/Error Codes */

dcl  (
     dm_error_$bj_pst_not_enough_buffers
     )			        fixed bin (35) external static;

/* External Static:  Data References */

dcl  (						/* external data references */
     dm_system_data_$bj_txt_relp      bit (18),
     sys_info$time_of_bootload        fixed bin (71)
     )			        external static;
/* Constants */

dcl  (
     PAGE_SIZE		        fixed bin init (1024),
     CI_SIZE		        fixed bin init (4096)
     )			        internal static options (constant);

/* Entries */

dcl  dm_per_system_$create	        entry (char (*), ptr);
dcl  dm_per_system_$alloc	        entry (fixed bin, ptr);

/* Builtin */
dcl  (
     addr, divide, mod,
     ptr, size, rel, unspec
     )			        builtin;
%page;
/* initialize the parameter */

	p_code = 0;

/* create the bj_pst */

	call dm_per_system_$create (BJ_PST, bj_pst_ptr);

	call INITIALIZE_PST ();
	if p_code ^= 0 then				/* sorry */
	     return;

/* allocate the bj_txt */

	call dm_per_system_$alloc (size (bj_txt), bj_txt_ptr);

	unspec (bj_txt) = "0"b;
	bj_txt_ptr -> bj_txt.max_n_entries = dm_system_data_$max_n_transactions;
	bj_txt_ptr -> bj_txt.version = BJ_TXT_VERSION_1;

	dm_system_data_$bj_txt_relp = rel (bj_txt_ptr);

	return;


/* end bjm_per_system_init_1_; */
%page;
INITIALIZE_PST:
     proc ();

	bj_pst.version = 0;
	unspec (bj_pst.lock) = "0"b;
	bj_pst.time_of_bootload = sys_info$time_of_bootload;
	bj_pst.max_n_entries = dm_system_data_$bj_max_n_journals;
	bj_pst.n_entries_used = 0;
	bj_pst.highest_ix_used = 0;

	bj_pst.pn_table_offset = PAGE_BOUNDARY (0 + size (bj_pst));
	bj_pst.check_in_table_offset = PAGE_BOUNDARY (bj_pst.pn_table_offset + size (bj_pn_table));
	bj_pst.buffer_table_offset = PAGE_BOUNDARY (bj_pst.check_in_table_offset + size (bj_check_in_table));

/* fill in max array bound for the various tables */
	ptr (bj_pst_ptr, bj_pst.pn_table_offset) -> bj_pn_table.max_n_entries = dm_system_data_$bj_max_n_journals;
	ptr (bj_pst_ptr, bj_pst.check_in_table_offset) -> bj_check_in_table.max_n_processes =
	     dm_system_data_$bj_max_n_processes;
	ptr (bj_pst_ptr, bj_pst.check_in_table_offset) -> bj_check_in_table.max_n_journals =
	     dm_system_data_$bj_max_n_journals;
	bj_pst.max_n_buffers = 255 - divide (bj_pst.buffer_table_offset, PAGE_SIZE, 17, 0);


	if bj_pst.max_n_buffers < dm_system_data_$bj_max_n_journals then do;
	     p_code = dm_error_$bj_pst_not_enough_buffers;
	     return;
	end;

	bj_pst.version = BJ_PST_VERSION_1;

	return;

     end INITIALIZE_PST;
%page;
PAGE_BOUNDARY:
     proc (w) returns (fixed bin (18) uns);

dcl  w			        fixed bin (18) uns;
dcl  n			        fixed bin (18) uns;

	n = mod (w, PAGE_SIZE);
	if n = 0 then return (w);
	else return (w + (PAGE_SIZE - n));

     end PAGE_BOUNDARY;


/* INCLUDE FILES start next page */
%page;%include dm_bj_static;
%page;%include dm_bj_pst;
%page;%include dm_bj_pste;
%page;%include dm_bj_pn_table;
%page;%include dm_bj_check_in_table;
%page;%include dm_bj_txt;
%page;%include dm_bj_names;
%page;%include dm_log_sv_codes;


     end bjm_per_system_init_1_;




		    collmgr_display.pl1             03/06/85  0751.0r w 03/05/85  0835.6      196317



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
collmgr_display:
cmds:
   proc ();

/*
DESCRIPTION:

     This command displays the collection_manager_ file_header, and the
collection_headers for each of the collections in a DM file.
*/

/*
HISTORY:

Written by Lindsey L. Spratt, 12/01/82.
Modified:
12/17/82 by Lindsey Spratt:  Added element displays and finer control over
	  what is displayed.
01/12/83 by Lindsey Spratt:  Fixed to initialize display_flag to "0"b.  Also
	  fixed messages for displaying elements.
03/08/83 by Lindsey Spratt:  Added special interpretation for a collection_idx
	  of 0.  This identifies the header collection.  Added the ability
	  to display an element formatted by an arbitrary structure (using
	  the display_structure technology).  Changed the -element control
	  option to only accept one element per option.
12/05/84 by Lindsey L. Spratt:  Fixed to declare the undeclared builtins.
*/
/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

      dcl	    file_dir	       char (168) init ("");
      dcl	    file_entry	       char (32) init ("");
      dcl	    (file_opening_id, current_collection_id)
			       bit (36) aligned init ("0"b);
      dcl	    work_area_ptr	       ptr init (null);
      dcl	    1 local_print_data_info
			       like print_data_info;
      dcl	    temp_string_ptr	       ptr init (null);
      dcl	    collection_idx	       fixed bin;
      dcl	    display_idx	       fixed bin init (0);
      dcl	    first_collection_idx   fixed bin init (0);
      dcl	    number_of_collections  fixed bin init (0);
      dcl	    1 automatic_cm_file_header
			       like cm_file_header;
      dcl	    collection_id_table_length_in_bits
			       fixed bin (35);
      dcl	    element_ptr	       ptr init (null);
      dcl	    element_length	       fixed bin (35) init (0);
      dcl	    (root_element_spec_ptr, element_spec_ptr, old_spec_ptr, next_ptr)
			       ptr init (null);

      dcl	    display_flag	       (7) bit (1) aligned;

      dcl	    display_info	       bit (1) aligned defined display_flag (1);
      dcl	    display_header	       bit (1) aligned defined display_flag (2);
      dcl	    display_file_header    bit (1) aligned defined display_flag (3);
      dcl	    display_collection_id_table
			       bit (1) aligned defined display_flag (4);
      dcl	    display_element	       bit (1) aligned defined display_flag (5);
      dcl	    display_element_in_characters
			       bit (1) aligned defined display_flag (6);
      dcl	    display_header_collection
			       bit (1) aligned defined display_flag (7);

      dcl	    true_arg	       char (32) varying init ("");

/* Based */

      dcl	    work_area	       area (sys_info$max_seg_size) based (work_area_ptr);
      dcl	    temp_string	       based (temp_string_ptr) char (sys_info$max_seg_size * 4) varying;

      dcl	    1 element_spec	       based (element_spec_ptr),
	      2 next	       ptr init (null),
	      2 structure_name     char (32) varying init (""),
	      2 collection_idx     fixed bin init (0),
	      2 position	       fixed bin (17),
	      2 id	       like element_id;

      dcl	    element	       based (element_ptr) bit (element_length);
      dcl	    character_element      based (element_ptr) char (divide (element_length, 9, 35, 0));

/* Builtin */

      dcl	    (addr, bin, char, divide, hbound, index, length, null, rtrim, substr, unspec)
			       builtin;

/* Constant */

      dcl	    BITS_PER_BYTE	       init (9) fixed bin (35) internal static options (constant);

      dcl	    DISPLAY_KEYWORD	       (7, 2) char (32) varying
			       init ("info", "i", "header", "h", "file_header", "fh", "collection_id_table", "cit",
			       "element", "e", "element_in_characters", "eic", "header_collection", "hc")
			       internal static options (constant);

      dcl	    myname	       init ("collmgr_display") char (32) varying internal static options (constant);
      dcl	    argument_type	       (9) internal static options (constant) char (64) varying
			       init ("DM file pathname", "index into the collection_id_table",
			       "index into the collection_id_table", "number of collections",
			       "number of collections", "keyword", "keyword", "element_id", "element_id");
      dcl	    control_argument       (9) internal static options (constant) char (64) varying
			       init ("-file", "-first_collection", "-ftc", "-number_of_collections", "-noc",
			       "-display", "-ds", "-element", "-el");

/* Entry */

      dcl	    ioa_		       entry () options (variable);
      dcl	    ioa_$nnl	       entry () options (variable);
      dcl	    file_manager_$open     entry (char (*), char (*), bit (36) aligned, fixed bin (35));
      dcl	    cm_opening_info$get    entry (bit (36) aligned, bit (36) aligned, ptr, fixed bin (35));
      dcl	    cm_get_element	       entry (bit (36) aligned, bit (36) aligned, bit (36) aligned, fixed bin, ptr,
			       fixed bin (35), ptr, bit (1) aligned, ptr, fixed bin (35), fixed bin (35));
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    get_system_free_area_  entry () returns (ptr);
      dcl	    get_temp_segment_      entry (char (*), ptr, fixed bin (35));
      dcl	    release_temp_segment_  entry (char (*), ptr, fixed bin (35));
      dcl	    print_data_	       entry (char (*) var, ptr, fixed bin (35));

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;
      dcl	    dm_error_$file_already_open
			       fixed bin (35) ext static;

/* END OF DECLARATIONS */

      display_flag = "0"b;
      display_file_header, display_info, display_header = "1"b;
      work_area_ptr = get_system_free_area_ ();

/* Process arguments. */

      call cu_$af_return_arg (nargs, return_arg_ptr, return_arg_len, code);
      if code = 0
      then is_active_function = "1"b;
      else if code = error_table_$not_act_fnc
      then is_active_function = "0"b;
      else
         do;
	  call com_err_ (code, myname);
	  return;
         end;

      if is_active_function
      then complain = active_fnc_err_;
      else complain = com_err_;

      if nargs = 0
      then
         do;
	  call complain (error_table_$noarg, myname, "^/Usage: ^a  {-control_args}", myname);
	  return;
         end;
      accept_control_argument = "1"b;
      control_argument_idx = 1;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to nargs;
         call cu_$arg_ptr (arg_idx, arg_ptr, arg_len, code);
         if char (arg, 1) ^= "-"
         then
PROCESS_ARG:
	  do;
	     goto ARG (control_argument_idx);


ARG (-1):						/* unexpected argument */
	     call complain (error_table_$badopt, myname, "Argument is out of place: ^a.", arg);
	     return;

ARG (1):						/* -file */
	     call expand_pathname_ (arg, file_dir, file_entry, code);
	     if code ^= 0
	     then
	        do;
		 call complain (code, myname, "^/Unable to expand the pathname ""^a"".", arg);
		 return;
	        end;

	     control_argument_idx = -1;
	     accept_control_argument = "1"b;
	     goto NEXT_1;
ARG (2):						/* -first_collection */
ARG (3):						/* -ftc */
	     first_collection_idx = bin (arg);

	     control_argument_idx = -1;
	     accept_control_argument = "1"b;
	     goto NEXT_1;
ARG (4):						/* -number_of_collections */
ARG (5):						/* -noc */
	     number_of_collections = bin (arg);

	     control_argument_idx = -1;
	     accept_control_argument = "1"b;
	     goto NEXT_1;
ARG (6):						/* -display */
ARG (7):						/* -ds */
	     if char (arg, 1) = "^"
	     then true_arg = substr (arg, 2);
	     else true_arg = arg;
	     do display_idx = 1 to hbound (DISPLAY_KEYWORD, 1)
		while (DISPLAY_KEYWORD (display_idx, 1) ^= true_arg & DISPLAY_KEYWORD (display_idx, 2) ^= true_arg);
	     end;
	     if display_idx > hbound (DISPLAY_KEYWORD, 1)
	     then
	        do;
		 call complain (error_table_$badopt, myname,
		      "^/Invalid display keyword ""^a"".  Valid display keywords are:
^v(^a (^a), ^)and ^a (^a).", arg, hbound (DISPLAY_KEYWORD, 1) - 1, DISPLAY_KEYWORD);
		 call FINISH;
		 return;
	        end;
	     display_flag (display_idx) = (arg = true_arg);

	     accept_control_argument = "1"b;
	     goto NEXT_1;

ARG (8):						/* -element */
ARG (9):						/* -el */
	     old_spec_ptr = element_spec_ptr;
	     alloc element_spec in (work_area);
	     if root_element_spec_ptr = null
	     then root_element_spec_ptr = element_spec_ptr;
	     else old_spec_ptr -> element_spec.next = element_spec_ptr;
	     element_spec.next = null;
	     element_spec.position = 0;
	     unspec (element_spec.id) = "0"b;
	     element_spec.collection_idx = bin (arg);
	     control_argument_idx = -2;
	     accept_control_argument = "0"b;
	     goto NEXT_1;

ARG (-2):
	     element_spec.id.control_interval_id = bin (arg);
	     control_argument_idx = -3;
	     accept_control_argument = "0"b;
	     goto NEXT_1;

ARG (-3):
	     element_spec.id.index = bin (arg);
	     control_argument_idx = -4;
	     accept_control_argument = "1"b;
	     goto NEXT_1;

ARG (-4):
	     element_spec.structure_name = arg;
	     control_argument_idx = -1;

	     accept_control_argument = "1"b;
	     goto NEXT_1;
NEXT_1:
	  end PROCESS_ARG;
         else if control_argument_idx ^= -1 & ^accept_control_argument
         then
	  do;
	     if control_argument_idx = -2 | control_argument_idx = -3
	     then control_argument_idx = 8;
	     call complain (error_table_$noarg, myname, "^a must be followed by a^[n^] ^a.",
		control_argument (control_argument_idx),
		(index ("aeiouh", substr (argument_type (control_argument_idx), 1, 1)) > 0),
		argument_type (control_argument_idx));
	     return;
	  end;
         else
PROCESS_CONTROL_ARG:
	  do;
	     do control_argument_idx = 1 to hbound (control_argument, 1)
		while (control_argument (control_argument_idx) ^= arg);
	     end;
	     if control_argument_idx > hbound (control_argument, 1)
	     then
	        do;
		 call complain (error_table_$badopt, myname, "^a", arg);
		 return;
	        end;

	     goto CONTROL_ARG (control_argument_idx);

CONTROL_ARG (0):
	     ;
CONTROL_ARG (1):					/* -file */
	     accept_control_argument = "0"b;
	     goto NEXT_ARG;

CONTROL_ARG (2):					/* -first_collection */
CONTROL_ARG (3):					/* -ftc */
	     accept_control_argument = "0"b;
	     goto NEXT_ARG;

CONTROL_ARG (4):					/* -number_of_collections */
CONTROL_ARG (5):					/* -noc */
	     accept_control_argument = "0"b;
	     goto NEXT_ARG;

CONTROL_ARG (6):					/* -display */
CONTROL_ARG (7):					/* -ds */
	     display_file_header, display_info, display_header = "1"b;
	     display_collection_id_table, display_element, display_element_in_characters = "0"b;

	     goto NEXT_ARG;

CONTROL_ARG (8):					/* -element */
CONTROL_ARG (9):					/* -el */
	     display_element = "1"b;

	     accept_control_argument = "0"b;
	     goto NEXT_ARG;

NEXT_ARG:
	     ;
	  end PROCESS_CONTROL_ARG;
      end ARG_PROCESSING_LOOP;
      if control_argument_idx ^= -1 & ^accept_control_argument
      then
         do;
	  if control_argument_idx = -2 | control_argument_idx = -3
	  then control_argument_idx = 8;
	  call complain (error_table_$noarg, myname, "^a must be followed by a^[n^] ^a.",
	       control_argument (control_argument_idx),
	       (index ("aeiouh", substr (argument_type (control_argument_idx), 1, 1)) > 0),
	       argument_type (control_argument_idx));
	  return;
         end;

      call get_temp_segment_ ((myname), temp_string_ptr, code);
      if code ^= 0
      then
         do;
	  call complain (code, myname, "^/Unable to get a temp_segment.");
	  call FINISH;
	  return;
         end;

      if file_dir = ""
      then
         do;
	  call complain (error_table_$noarg, myname, "^/A DM file pathname must be specified.");
	  call FINISH;
	  return;
         end;

      call file_manager_$open (file_dir, file_entry, file_opening_id, code);
      if code ^= 0 & code ^= dm_error_$file_already_open
      then
         do;
	  call complain (code, myname, "^/Unable to open the file ""^a^[>^]^a"".", file_dir, file_dir ^= ">",
	       file_entry);
	  call FINISH;
	  return;
         end;

      call cm_opening_info$get (file_opening_id, HEADER_COLLECTION_ID, cm_info_ptr, code);
      if code ^= 0
      then
         do;
	  call complain (code, myname, "^/Unable to get the opening info for the header collection (id ^o), for
file ""^a^[>^]^a"".", HEADER_COLLECTION_ID, file_dir, file_dir ^= ">", file_entry);
	  call FINISH;
	  return;
         end;

      call cm_get_element (cm_info.file_oid, cm_info.collection_id, CM_FILE_HEADER_ELEMENT_ID, 0,
	 addr (automatic_cm_file_header), length (unspec (automatic_cm_file_header)), null, ("0"b), cm_file_header_ptr,
	 (0), code);
      if code ^= 0
      then
         do;
	  call complain (code, myname, "^/Unable to get the file_header.");
	  call FINISH ();
	  return;
         end;


      if cm_file_header.number_of_collections = 0
      then
         do;
	  call complain (0, myname, "^/The file ""^a^[>^]^a"" contains no collections.", file_dir, file_dir ^= ">",
	       file_entry);
	  call FINISH;
	  return;
         end;

      print_data_info_ptr = addr (local_print_data_info);

      call cm_get_element (cm_info.file_oid, HEADER_COLLECTION_ID, cm_file_header.collection_id_table_element_id, 0, null,
	 (0), work_area_ptr, "1"b, collection_id_table_ptr, collection_id_table_length_in_bits, code);
      if code ^= 0
      then
         do;
	  call complain (code, myname, "^/Unable to get the collection_id_table.");
	  call FINISH ();
	  return;
         end;
      cit_number_of_collections = cm_file_header.number_of_collections;

      print_data_info.version = print_data_info_version_1;
      print_data_info.indentation = 2;
      print_data_info.value_column = 30;
      print_data_info.output_switch = null;
      print_data_info.flags.octal = "1"b;
      print_data_info.intervals = "";

      if display_file_header
      then
         do;
	  put string (temp_string) data (cm_file_header);
	  call print_data_ (temp_string, print_data_info_ptr, code);
	  if code ^= 0
	  then
	     do;
	        call complain (code, myname, "^/Unable to display the cm_file_header structure.");
	        call FINISH;
	        return;
	     end;

         end;
      if display_collection_id_table
      then
         do;
	  put string (temp_string) data (collection_id_table);
	  call print_data_ (temp_string, print_data_info_ptr, code);
	  if code ^= 0
	  then
	     do;
	        call complain (code, myname, "^/Unable to display the collection_id_table structure.");
	        call FINISH;
	        return;
	     end;
         end;

      if display_header_collection
      then
         do;
	  call ioa_ ("^/The header collection, id ^o:", HEADER_COLLECTION_ID);
	  if display_info
	  then
	     do;
	        put string (temp_string) data (cm_info);
	        call print_data_ (temp_string, print_data_info_ptr, code);
	     end;
	  if display_header
	  then
	     do;
	        put string (temp_string) data (cm_info.header_ptr -> collection_header);
	        call print_data_ (temp_string, print_data_info_ptr, code);
	     end;
         end;

      if first_collection_idx = 0
      then first_collection_idx = 1;
      if number_of_collections = 0
      then number_of_collections = cit_number_of_collections - first_collection_idx + 1;

      if ^display_element
      then
COLLECTION_LOOP:
         do collection_idx = first_collection_idx to first_collection_idx + number_of_collections - 1;

	  call ioa_ ("^/Collection ^d - id ^o:", collection_idx, collection_id_table (collection_idx));

	  call cm_opening_info$get (file_opening_id, collection_id_table (collection_idx), cm_info_ptr, code);
	  if code ^= 0
	  then
	     do;
	        call complain (code, myname, "^/Unable to get the opening info for the header collection (id ^o), for
file ""^a^[>^]^a"".", collection_id_table (collection_idx), file_dir, file_dir ^= ">", file_entry);
	        call FINISH;
	        return;
	     end;

	  if display_info
	  then
	     do;
	        put string (temp_string) data (cm_info);
	        call print_data_ (temp_string, print_data_info_ptr, code);
	        if code ^= 0
	        then
		 do;
		    call complain (code, myname,
		         "^/Unable to display the cm_info structure for collection ^d, with id ^o.", collection_idx,
		         collection_id_table (collection_idx));
		    call FINISH;
		    return;
		 end;
	     end;
	  if display_header
	  then
	     do;
	        put string (temp_string) data (cm_info.header_ptr -> collection_header);
	        call print_data_ (temp_string, print_data_info_ptr, code);
	        if code ^= 0
	        then
		 do;
		    call complain (code, myname, "^/Unable to display the collection_header structure.");
		    call FINISH;
		    return;
		 end;
	     end;

         end COLLECTION_LOOP;
      else
ELEMENT_DISPLAY:
         do;
	  do element_spec_ptr = root_element_spec_ptr repeat (element_spec.next) while (element_spec_ptr ^= null);
	     if element_spec.collection_idx > 0
	     then current_collection_id = collection_id_table (element_spec.collection_idx);
	     else current_collection_id = HEADER_COLLECTION_ID;
	     call cm_get_element (file_opening_id, current_collection_id, unspec (element_spec.id),
		element_spec.position, null, (0), work_area_ptr, ("0"b), element_ptr, element_length, code);
	     if code ^= 0
	     then
	        do;
		 call complain (code, myname, "^/Unable to get element in slot ^d of control interval ^d 
(in collection number ^d with id ^o).", element_spec.id.index, element_spec.id.control_interval_id,
		      element_spec.collection_idx, current_collection_id);
		 call FINISH;
		 return;
	        end;

	     call ioa_ ("Element for slot ^d of control interval ^d (collection ^o,  number ^d):",
		element_spec.id.index, element_spec.id.control_interval_id, current_collection_id,
		element_spec.collection_idx);

	     if element_spec.structure_name ^= ""
	     then call DISPLAY_ELEMENT_BY_STRUCTURE (addr (element), (element_spec.structure_name), code);
	     else if display_element_in_characters
	     then call ioa_ ("^a", character_element);
	     else call ioa_ ("^.3b", element);

	     free element in (work_area);

	  end;
         end ELEMENT_DISPLAY;

      call FINISH;
      return;
%page;
FINISH:
   proc;
      if temp_string_ptr ^= null
      then call release_temp_segment_ ((myname), temp_string_ptr, code);
   end FINISH;
%page;
DISPLAY_ELEMENT_BY_STRUCTURE:
   proc (p_structure_ptr, p_structure_name, p_code);
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$generate_call      entry (entry, ptr);
      dcl	    hcs_$make_entry	       entry (ptr, char (*), char (*), entry, fixed bin (35));
      dcl	    p_structure_ptr	       ptr parameter;
      dcl	    p_structure_name       char (*) parameter;
      dcl	    p_code	       fixed bin (35);
      dcl	    arg_list_ptr	       ptr;
      dcl	    structure_entry	       entry variable;
      dcl	    procedure_name	       char (32);

      procedure_name = "display_" || rtrim (p_structure_name) || "_";

      call hcs_$make_entry (null, procedure_name, procedure_name, structure_entry, p_code);
      if p_code ^= 0
      then return;

      call MAKE_STRUCTURE_CALL (p_structure_ptr, temp_string);

      call print_data_ (temp_string, print_data_info_ptr, p_code);

      return;

MAKE_STRUCTURE_CALL:
   proc () options (variable);

      call cu_$arg_list_ptr (arg_list_ptr);
      call cu_$generate_call (structure_entry, arg_list_ptr);
   end MAKE_STRUCTURE_CALL;
   end DISPLAY_ELEMENT_BY_STRUCTURE;
%page;
/* BEGIN INCLUDE FILE control_argument_dcls.incl.pl1 */

/* This file contains all of the commonly used declarations for commands 
concerning control argument processing.

Written  by  Lindsey Spratt, 08/28/79
*/
      dcl	    cu_$arg_count	       entry returns (fixed bin);
      dcl	    cu_$arg_ptr	       entry (fixed bin, ptr, fixed bin, fixed bin (35));
      dcl	    cu_$af_return_arg      entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
      dcl	    com_err_	       entry options (variable);
      dcl	    active_fnc_err_	       entry () options (variable);
      dcl	    complain	       entry () variable options (variable);
      dcl	    return_arg	       char (return_arg_len) based (return_arg_ptr) varying;
      dcl	    return_arg_len	       fixed bin (21);
      dcl	    return_arg_ptr	       ptr;
      dcl	    arg		       based (arg_ptr) char (arg_len);
      dcl	    arg_ptr	       ptr;
      dcl	    arg_len	       fixed bin;
      dcl	    arg_idx	       fixed bin;
      dcl	    nargs		       fixed bin;

      dcl	    control_argument_idx   fixed bin;
      dcl	    accept_control_argument
			       bit (1);
      dcl	    is_active_function     bit (1);
      dcl	    code		       fixed bin (35);

      dcl	    error_table_$noarg     fixed bin (35) ext;
      dcl	    error_table_$badopt    fixed bin (35) ext;
      dcl	    error_table_$bad_arg   fixed bin (35) ext;
      dcl	    error_table_$not_act_fnc
			       fixed bin (35) ext;	/*dcl error_table_$active_function fixed bin(35) ext; */

/* END INCLUDE FILE control_argument_dcls.incl.pl1 */
%page;
%page;
%include dm_cm_hdr_col_ids;
%page;
%include dm_hdr_collection_id;
%page;
%include dm_cm_info;
%page;
%include dm_cm_collection_header;
%page;
%include dm_cm_storage_record;
%page;
%include dm_element_id;
%page;
%include print_data_info;
%page;
%include dm_cm_file_header;
   end collmgr_display;




		    copy_dm_file_.pl1               03/06/85  0751.0re  03/05/85  0755.9       87894



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

copy_dm_file_: proc (A_copy_options_ptr, A_code);

/* DESCRIPTION:

   Copying primitive for DM files. Takes all its input info in the copy_options
   structure. The return code, if zero, pertains to the target file if
   copy_options.target_err_switch is ON, otherwise to the file being copied.

   The source file is opened, the target file is created and opened, and
   copying is performed by successive calls to fm_$raw_put to copy the
   control intervals. This way, new control interval id's are generated and
   a new protected file is built.
*/

/* HISTORY:
Written by Steve Herbst, 03/22/83.
Modified:
04/13/83 by Steve Herbst: Changed to use raw_(get put) and abort if interrupted. 
05/25/83 by Steve Herbst: Eliminated erroneous call to fm_$delete_close 
06/17/83 by Steve Herbst: Changed calling sequence to use new copy_options 
            include file.
06/28/83 by Steve Herbst: Changed to use copy_flags.incl.pl1 
08/20/84 by Matthew C. Pierret: Changed to use FILE_CREATE_INFO_VERSION_2.
10/15/84 by Steve Herbst: Changed in response to audit comments:
	Removed cleanup windows, Added ERROR_RETURN proc, changed to call
	file_manager_$get_ci_ptr instead of $raw_get.
12/13/84 by Steve Herbst: Changed again in response to audit comments:
	Fixed CLEAN_UP to not delete source file, added copy_options version
	check, removed references to ci_header, changed to report CLEAN_UP
	errors at normal termination, fixed to never call CLEAN_UP twice.
12/17/84 by Steve Herbst: Changed again in response to audit comments:
	Improved journalization comments, fixed not to replace nonzero
	A_code with error code from CLEAN_UP, commented CLEAN_UP design.
12/18/84 by Matthew Pierret:  Changed to initialize auto_ci_parts.mbz to 0
            and auto_ci_parts.number_of_parts to 1.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_copy_options_ptr ptr parameter;
dcl  A_code fixed bin (35) parameter;

/* Based */

/* Automatic */

dcl  1 auto_ci_parts aligned,
       2 number_of_parts fixed bin init (1),
       2 mbz fixed bin init (0),
       2 part (1) like ci_parts.part;

dcl  1 auto_file_create_info aligned like file_create_info;
dcl  (source_opening_id, target_opening_id, txn_id) bit (36) aligned;
dcl  (cleanup_called_sw, done_sw, getting_sw) bit (1);
dcl  (ci_index, last_ci_num) fixed bin (27);
dcl  (begin_code, code, create_code) fixed bin (35);

/* External */

dcl  dm_error_$ci_not_allocated fixed bin (35) ext;
dcl  dm_error_$file_already_exists fixed bin (35) ext;
dcl  dm_error_$file_already_open fixed bin (35) ext;
dcl  dm_error_$file_not_dm_type fixed bin (35) ext;
dcl  dm_error_$transaction_in_progress fixed bin (35) ext;
dcl  error_table_$dirseg fixed bin (35) ext;
dcl  error_table_$not_seg_type fixed bin (35) ext;
dcl  error_table_$rqover fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;

/* Entries */

dcl  file_manager_$close entry (bit (36) aligned, fixed bin (35));
dcl  file_manager_$create_open entry (char (*), char (*), ptr, bit (36) aligned, fixed bin (35));
dcl  file_manager_$delete entry (bit (36) aligned, fixed bin (35));
dcl  file_manager_$get_ci_ptr entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
dcl  file_manager_$open entry (char (*), char (*), bit (36) aligned, fixed bin (35));
dcl  file_manager_$prepare_to_copy entry (bit (36) aligned, ptr, fixed bin (27), fixed bin (35));
dcl  file_manager_$raw_put entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
dcl  file_manager_$terminate_ci_ptr entry (bit (36) aligned, fixed bin (27), ptr, fixed bin (35));
dcl  transaction_manager_$abort_txn entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$begin_txn entry (fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$commit_txn entry (bit (36) aligned, fixed bin (35));

/* Builtins */

dcl  (addr, null, unspec) builtin;

/* Conditions */

dcl  (cleanup, record_quota_overflow) condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;
	copy_options_ptr = A_copy_options_ptr;

	if copy_options.version ^= COPY_OPTIONS_VERSION_1 then
	     call ERROR_RETURN (error_table_$unimplemented_version);

	copy_options.target_err_switch = "0"b;		/* assume source file until target error occurs */

	cleanup_called_sw = "0"b;
	done_sw, getting_sw = "0"b;
	txn_id, source_opening_id, target_opening_id = "0"b;
	begin_code, create_code = 0;

	on cleanup call CLEAN_UP (code);

	call transaction_manager_$begin_txn (TM_NORMAL_MODE, "0"b, txn_id, begin_code);
	if begin_code ^= 0 & begin_code ^= dm_error_$transaction_in_progress then call ERROR_RETURN (begin_code);
						/* OK to use an existing transaction */

	call file_manager_$open (copy_options.source_dir, copy_options.source_name, source_opening_id, code);
	if source_opening_id = "0"b then
	     if code = error_table_$dirseg | code = dm_error_$file_not_dm_type then
		call ERROR_RETURN (error_table_$not_seg_type);
	     else call ERROR_RETURN (code);

	unspec (auto_file_create_info) = "0"b;
	auto_file_create_info.version = FILE_CREATE_INFO_VERSION_2;
	call file_manager_$prepare_to_copy (source_opening_id, addr (auto_file_create_info), last_ci_num, code);
	if code ^= 0 then call ERROR_RETURN (code);

	on record_quota_overflow begin;
	     copy_options.target_err_switch = ^getting_sw;
	     call ERROR_RETURN (error_table_$rqover);
	end;

	call file_manager_$create_open (copy_options.target_dir, copy_options.target_name,
	     addr (auto_file_create_info), target_opening_id, create_code);
	if target_opening_id = "0"b | create_code = dm_error_$file_already_exists then do;
	     copy_options.target_err_switch = "1"b;
	     call ERROR_RETURN (create_code);
	end;

	auto_ci_parts.offset_in_bytes (1) = 0;
	auto_ci_parts.local_ptr (1) = null;
	auto_ci_parts.length_in_bytes = CI_0_ADDRESSABLE_LENGTH;

	do ci_index = 0 to last_ci_num;

/* Copy only used control intervals */

	     getting_sw = "1"b;
	     call file_manager_$get_ci_ptr (source_opening_id, ci_index, auto_ci_parts.local_ptr (1), code);
	     getting_sw = "0"b;

	     if code = 0 then do;			/* copy this one; it's allocated */

		call file_manager_$raw_put (target_opening_id, ci_index, addr (auto_ci_parts), code);
		if code ^= 0 then do;
		     copy_options.target_err_switch = "1"b; /* error is on the target file */
		     call ERROR_RETURN (code);
		end;

		call file_manager_$terminate_ci_ptr (source_opening_id, ci_index, auto_ci_parts.local_ptr (1), code);
		if code ^= 0 then call ERROR_RETURN (code);
	     end;
	     else if code ^= dm_error_$ci_not_allocated then call ERROR_RETURN (code);
						/* if it's not allocated, just skip it */
	     auto_ci_parts.length_in_bytes = CI_ADDRESSABLE_LENGTH;
	end;

	auto_ci_parts.local_ptr (1) = null;

	done_sw = "1"b;
RETURN:
	if ^cleanup_called_sw then do;
	     cleanup_called_sw = "1"b;
	     call CLEAN_UP (code);
	     if code ^= 0 & A_code = 0 then call ERROR_RETURN (code); /* previously reported A_code takes precedence */
	end;

	return;
%page;
CLEAN_UP: proc (P_cleanup_code);

/* This procedure completes even if one of its calls gets an error, since the
   intent is to return the process and the objects to their former state as
   well as possible. It sets a code parameter rather than reporting an error
   so that the caller has the option: an error is reported at normal
   termination time but not when "cleanup" is signalled. */

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

	P_cleanup_code = 0;				/* reports errors to the main proc */
						/* want to report 1st error but do all cleanup */

	if auto_ci_parts.local_ptr (1) ^= null then	/* was in the middle of reading a ci */
	     call file_manager_$terminate_ci_ptr
		(source_opening_id, ci_index, auto_ci_parts.local_ptr (1), P_cleanup_code);

	if source_opening_id ^= "0"b then call file_manager_$close (source_opening_id, code);
	if P_cleanup_code = 0 then P_cleanup_code = code;

	if target_opening_id ^= "0"b & create_code ^= dm_error_$file_already_open then
	     call file_manager_$close (target_opening_id, code);
	if P_cleanup_code = 0 then do;
	     P_cleanup_code = code;
	     copy_options.target_err_switch = "1"b;
	end;

	if txn_id ^= "0"b then
	     if begin_code = dm_error_$transaction_in_progress then ;
						/* What to do? Can't commit or abort the user's previous transaction. */

	     else if done_sw then do;
		call transaction_manager_$commit_txn (txn_id, code);
		if P_cleanup_code = 0 then P_cleanup_code = code;
	     end;
	     else do;				/* if ^done_sw, target may be incomplete. */
						/* have to delete it if we created it */
		if target_opening_id ^= "0"b & create_code ^= dm_error_$file_already_exists &
		     create_code ^= dm_error_$file_already_open then do;
		     call file_manager_$delete (target_opening_id, code);
		     if P_cleanup_code = 0 then do;
			P_cleanup_code = code;
			copy_options.target_err_switch = "1"b;
		     end;
		end;

		call transaction_manager_$abort_txn (txn_id, code);
		if P_cleanup_code = 0 then P_cleanup_code = code;
	     end;

     end CLEAN_UP;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;
	go to RETURN;

     end ERROR_RETURN;
%page;
%include copy_flags;
%page;
%include copy_options;
%page;
%include dm_ci_lengths;
%page;
%include dm_ci_parts;
%page;
%include dm_file_create_info;
%page;
%include dm_tm_modes;


     end copy_dm_file_;




		    create_dm_file.pl1              04/04/85  1114.9re  04/04/85  0824.8      164304



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


Syntax:  create_dm_file PATH {-control_args}


Function:  This command creates an empty Data Management file.


Arguments:
PATH
   is the pathname of the Data Management file to be created.


Control arguments:
-protected, -prot
   makes the dmf protected.  All references to a protected dmf must be
   done with a transaction in progress.  (DEFAULT)
-unprotected, -unprot, -not_protected, -nprot
   makes the dmf unprotected.  An unprotected dmf can be accessed
   outside of a transaction.
-concurrency, -conc
   makes the dmf automatically protected from concurrent access
   conflicts.  This implies the dmf is protected.  (DEFAULT)
-no_concurrency, -nconc
   makes the dmf unprotected from concurrent access conflicts.  This
   option implies the dmf is protected.
-rollback, -rlb
   makes the dmf protected from transaction interruptions (user,
   process, or system-caused), by supporting the rolling-back of all
   modifications made to the dmf by the interrupted transaction.  This
   option implies the dmf is protected.  (DEFAULT)


-no_rollback, -nrlb
   makes the dmf unprotected with respect to transaction interruptions.
   This option implies that the dmf is protected.
-ring_brackets W {R}, -rb W {R}
   sets the extended write ring bracket to W and the extended read ring
   bracket to R.  The extended write ring bracket must be less than or
   equal to the extended read ring bracket, i.e.  W <= R.


Notes:  When two mutually exclusive options are given, the rightmost
one on the command line is used, and the leftmost is ignored.  The
-unprotected option is mutually exclusive with the -protected,
-rollback, -no_rollback, -concurrency and -no_concurrency options.

*/

/* HISTORY:

Written by Lindsey L. Spratt, 12/02/84.
Modified:
12/05/84 by Lindsey L. Spratt:  Changed to use the FCI_*_BRACKET_IDX constants
            in the dm_file_create_info incl file.  Fixed to destroy the
            standalone invocation.
01/10/85 by Lindsey L. Spratt:  Added the default_control_argument_idx var to
            allow the pathname to be provided at any point in the command
            line.  Dcl'ed some builtins.  Changed to use ssu_$arg_count
            instead of ssu_$return_arg.
01/23/85 by Lindsey L. Spratt:  Removed the dcl of 
	  error_table_$active_function.
03/19/85 by S. Cox: Added dm_not_available_ handler.
*/
/* format: style2,ind3 */
%page;
create_dm_file:
   proc ();

/* START OF DECLARATIONS */
/* Automatic */

      dcl	    accept_control_argument
			       bit (1) aligned init (NO);
      dcl	    arg_idx	       fixed bin;
      dcl	    arg_len	       fixed bin (21);
      dcl	    arg_list_ptr	       ptr init (null);
      dcl	    arg_ptr	       ptr;
      dcl	    code		       fixed bin (35);
      dcl	    control_argument_idx   fixed bin;
      dcl	    current_transaction_id bit (36) aligned init ("0"b);
      dcl	    current_transaction_is_defined_by_this_command
			       bit (1) aligned init (NO);
      dcl	    default_control_argument_idx
			       fixed bin init (-1);
      dcl	    dir_path	       char (168) init (UNSET_DIR_PATH);
      dcl	    entry_name	       char (32) init ("");
      dcl	    force_interpretation_as_argument
			       bit (1) aligned init (NO);
      dcl	    is_active_function     bit (1) aligned init (NO);
      dcl	    1 local_file_create_info
			       aligned like file_create_info;
      dcl	    number_of_args	       fixed bin;
      dcl	    return_arg_len	       fixed bin (21) init (0);
      dcl	    return_arg_ptr	       ptr init (null);
      dcl	    sci_ptr	       ptr init (null);
      dcl	    this_is_a_standalone_invocation
			       bit (1) aligned init (YES);
      dcl	    validation_level       fixed bin init (0);

/* Based */

      dcl	    arg		       char (arg_len) based (arg_ptr);

/* Builtin */

      dcl	    (addr, hbound, index, null, substr)
			       builtin;

/* Condition */

      dcl	    (cleanup, dm_not_available_)
			       condition;

/* Constant */

      dcl	    (
	    YES		       init ("1"b),
	    NO		       init ("0"b),
	    SUCCESS_EXIT	       init ("1"b),
	    FAILURE_EXIT	       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);
      dcl	    DEFAULT_BJ	       init ("0"b) bit (36) internal static options (constant);

      dcl	    UNSET_DIR_PATH	       init ("<UNSET DIR PATH<") char (168) internal static options (constant);

      dcl	    myname	       init ("create_dm_file") char (14) internal static options (constant);

      dcl	    ARGUMENT_TYPE	       (19) internal static options (constant) char (64) varying
			       init ("", "", "", "", "", "", "", "", "", "", "", "", "", "",
			       "integer greater than or equal to the validation level",
			       "integer greater than or equal to the validation level",
			       "integer greater than or equal to the validation level",
			       "pathname of the to-be-created dmf", "pathname of the to-be-created dmf");

      dcl	    CONTROL_ARGUMENT       (19) internal static options (constant) char (64) varying
			       init ("-protected", "-prot", "-not_protected", "-nprot", "-unprotected", "-unprot",
			       "-rollback", "-rlb", "-no_rollback", "-nrlb", "-concurrency", "-conc",
			       "-no_concurrency", "-nconc", "-ring_brackets", "-rb", "" /*2nd -rb argument*/,
			       "X-pathname" /* Can only be given as 1st arg. */, "X-pn");

      dcl	    PATHNAME_CONTROL_ARGUMENT_IDX
			       init (18) fixed bin internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cv_dec_check_	       entry (char (*), fixed bin (35)) returns (fixed bin (35));
      dcl	    expand_pathname_       entry (char (*), char (*), char (*), fixed bin (35));
      dcl	    file_manager_$create   entry (char (*), char (*), ptr, fixed bin (35));
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));
      dcl	    ssu_$abort_line	       entry () options (variable);
      dcl	    ssu_$arg_ptr	       entry (ptr, fixed bin, ptr, fixed bin (21));
      dcl	    ssu_$arg_count	       entry (ptr, fixed bin);
      dcl	    ssu_$destroy_invocation
			       entry (ptr);
      dcl	    ssu_$standalone_invocation
			       entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
      dcl	    transaction_manager_$abort_txn
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    transaction_manager_$begin_txn
			       entry (fixed bin (17), bit (36), bit (36) aligned, fixed bin (35));
      dcl	    transaction_manager_$commit_txn
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    transaction_manager_$get_current_txn_id
			       entry (bit (36) aligned, fixed bin (35));


/* External */

      dcl	    (
	    dm_error_$no_current_transaction,
	    dm_error_$system_not_initialized,
	    error_table_$bad_arg,
	    error_table_$badopt,
	    error_table_$noarg
	    )		       fixed bin (35) external;

/* END OF DECLARATIONS */
%page;
      on cleanup call CLEANUP ();

      call cu_$level_get (validation_level);

      local_file_create_info.version = FILE_CREATE_INFO_VERSION_2;
      local_file_create_info.ci_size_in_bytes = 4096;
      local_file_create_info.blocking_factor = 255;
      local_file_create_info.flags.protected = YES;
      local_file_create_info.flags.no_concurrency = NO;
      local_file_create_info.flags.no_rollback = NO;
      local_file_create_info.flags.mbz_1 = "0"b;
      local_file_create_info.ring_brackets (*) = validation_level;
      local_file_create_info.mbz_3 = "0"b;
      local_file_create_info.mbz_2 (*) = 0;

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on dm_not_available_ call ssu_$abort_line (sci_ptr, dm_error_$system_not_initialized, "", myname);

      call ssu_$arg_count (sci_ptr, number_of_args);

      if number_of_args = 0
      then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage: ^a PATH {-control_arguments}", myname);

      default_control_argument_idx = PATHNAME_CONTROL_ARGUMENT_IDX;
      accept_control_argument = YES;
      control_argument_idx = default_control_argument_idx;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to number_of_args;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES
         then call PROCESS_ARGUMENT (arg, control_argument_idx, accept_control_argument);
         else if accept_control_argument = YES
         then call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx, accept_control_argument,
	         force_interpretation_as_argument);
         else call REPORT_MISSING_ARGUMENT (control_argument_idx);
      end ARG_PROCESSING_LOOP;

      if control_argument_idx >= 0 & accept_control_argument = NO
      then call REPORT_MISSING_ARGUMENT (control_argument_idx);


      if local_file_create_info.protected = YES
      then
         do;
	  call transaction_manager_$get_current_txn_id (current_transaction_id, code);
	  if code = 0
	  then current_transaction_is_defined_by_this_command = NO;
	  else if code = dm_error_$no_current_transaction
	  then
	     do;
	        current_transaction_is_defined_by_this_command = YES;
	        call transaction_manager_$begin_txn (TM_NORMAL_MODE, DEFAULT_BJ, current_transaction_id, code);
	        if code ^= 0
	        then call ssu_$abort_line (sci_ptr, code,
		        "^/Unable to begin a transaction (which is necessary to create a data management file).");
	     end;
	  else call ssu_$abort_line (sci_ptr, code,
		  "^/Unable to determine if there is a transaction in progress in this process.");
         end;

      call file_manager_$create (dir_path, entry_name, addr (local_file_create_info), code);
      if code ^= 0
      then call ssu_$abort_line (sci_ptr, code, "^/Unable to create the data management file ^a.",
	      pathname_ (dir_path, entry_name));

      call FINISH (SUCCESS_EXIT);

MAIN_RETURN:
      return;
%page;
ABORT_ENTRY:
   procedure ();
      call CLEANUP ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;


CLEANUP:
   proc ();
      call FINISH (FAILURE_EXIT);
   end CLEANUP;

FINISH:
   procedure (f_p_exit_type);
      dcl	    f_p_exit_type	       bit (1) aligned parm;

      call ssu_$destroy_invocation (sci_ptr);

      if current_transaction_is_defined_by_this_command = YES
      then if f_p_exit_type = FAILURE_EXIT
	 then call transaction_manager_$abort_txn (current_transaction_id, (0));
	 else call transaction_manager_$commit_txn (current_transaction_id, (0));
   end FINISH;



PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

      dcl	    pa_p_arg	       char (*) parm;
      dcl	    pa_p_control_argument_idx
			       fixed bin parm;
      dcl	    pa_p_accept_control_argument
			       bit (1) aligned parm;

      dcl	    pa_code	       fixed bin (35);

      pa_code = 0;

      goto ARGUMENT (pa_p_control_argument_idx);
ARGUMENT (-1):
      call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The argument ""^a"" is out of place.", arg);
      return;

ARGUMENT (15):					/* -ring_brackets */
ARGUMENT (16):					/* -rb */
      local_file_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX) =
	 CONVERT_RING_BRACKET (validation_level, "current validation level", "write", arg);
      local_file_create_info.ring_brackets (FCI_READ_BRACKET_IDX) =
	 local_file_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX);

      pa_p_accept_control_argument = YES;
      pa_p_control_argument_idx = 17;
      return;

ARGUMENT (17):					/* The read ring bracket, optional. */
      local_file_create_info.ring_brackets (FCI_READ_BRACKET_IDX) =
	 CONVERT_RING_BRACKET ((local_file_create_info.ring_brackets (FCI_WRITE_BRACKET_IDX)), "write bracket", "read",
	 arg);

      pa_p_accept_control_argument = YES;
      pa_p_control_argument_idx = default_control_argument_idx;
      return;

ARGUMENT (18):					/* -pathname */
ARGUMENT (19):					/* -pn */
      call expand_pathname_ (arg, dir_path, entry_name, code);
      if code ^= 0
      then call ssu_$abort_line (sci_ptr, code, "^/Unable to expand the pathname of the data management file, ^a.", arg);

      pa_p_control_argument_idx = default_control_argument_idx;
      pa_p_accept_control_argument = YES;
      return;

   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument, pca_p_force_interpretation_as_argument);


      dcl	    pca_p_arg	       char (*) parm;
      dcl	    pca_p_control_argument_idx
			       fixed bin parm;
      dcl	    pca_p_accept_control_argument
			       bit (1) aligned parm;
      dcl	    pca_p_force_interpretation_as_argument
			       bit (1) aligned parm;


      pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
      pca_p_accept_control_argument = YES;
      pca_p_force_interpretation_as_argument = NO;

      go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
      call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* -protected */
CONTROL_ARGUMENT (2):				/* -prot */
      local_file_create_info.protected = YES;

      pca_p_control_argument_idx = default_control_argument_idx;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (3):				/* -not_protected */
CONTROL_ARGUMENT (4):				/* -nprot */
CONTROL_ARGUMENT (5):				/* -unprotected */
CONTROL_ARGUMENT (6):				/* -unprot */
      local_file_create_info.protected = NO;

      pca_p_control_argument_idx = default_control_argument_idx;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (7):				/* -rollback */
CONTROL_ARGUMENT (8):				/* -rlb */
      local_file_create_info.protected = YES;
      local_file_create_info.no_rollback = NO;

      pca_p_control_argument_idx = default_control_argument_idx;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (9):				/* -no_rollback */
CONTROL_ARGUMENT (10):				/* -nrlb */
      local_file_create_info.protected = YES;
      local_file_create_info.no_rollback = YES;

      pca_p_control_argument_idx = default_control_argument_idx;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (11):				/* -concurrency */
CONTROL_ARGUMENT (12):				/* -conc */
      local_file_create_info.protected = YES;
      local_file_create_info.no_concurrency = NO;

      pca_p_control_argument_idx = default_control_argument_idx;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (13):				/* -no_concurrency */
CONTROL_ARGUMENT (14):				/* -nconc */
      local_file_create_info.protected = YES;
      local_file_create_info.no_concurrency = YES;

      pca_p_control_argument_idx = default_control_argument_idx;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (15):				/* -ring_brackets */
CONTROL_ARGUMENT (16):				/* -rb */
      pca_p_accept_control_argument = NO;
      return;


CONTROL_ARGUMENT (18):				/* -pathname */
CONTROL_ARGUMENT (19):				/* -pn */
      pca_p_accept_control_argument = NO;
      return;


   end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

      dcl	    cai_p_arg	       char (*);
      dcl	    cai_control_argument_idx
			       fixed bin;

      do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	 while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
      end;
      if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
      then return (-1);
      else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;

REPORT_MISSING_ARGUMENT:
   proc (rma_p_control_argument_idx);

      dcl	    rma_p_control_argument_idx
			       fixed bin parm;

      if rma_p_control_argument_idx = PATHNAME_CONTROL_ARGUMENT_IDX
      then call ssu_$abort_line (sci_ptr, error_table_$noarg,
	      "The first argument to this command must be the pathname of the data management file to be created.");
      else call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	      CONTROL_ARGUMENT (rma_p_control_argument_idx),
	      (index ("aeiouh", substr (ARGUMENT_TYPE (rma_p_control_argument_idx), 1, 1)) > 0),
	      ARGUMENT_TYPE (rma_p_control_argument_idx));

   end REPORT_MISSING_ARGUMENT;


CONVERT_RING_BRACKET:
   proc (crb_p_minimum_ring, crb_p_minimum_ring_name, crb_p_ring_bracket_name, crb_p_ring_number_string)
        returns (fixed bin (3));
      dcl	    crb_p_minimum_ring     fixed bin (17) parm;
      dcl	    crb_p_minimum_ring_name
			       char (*);
      dcl	    crb_p_ring_bracket_name
			       char (*);
      dcl	    crb_p_ring_number_string
			       char (*);

      dcl	    crb_code	       fixed bin (35) init (0);
      dcl	    crb_ring_bracket       fixed bin (35) init (0);

      crb_ring_bracket = cv_dec_check_ (crb_p_ring_number_string, crb_code);
      if crb_code ^= 0
      then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/Unable to convert the ring bracket ""^a"".", arg);

      if crb_ring_bracket < crb_p_minimum_ring
      then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The specified ^a bracket, ^d, is too low.  
It must be greater than or equal to the ^a, ^d.", crb_p_ring_bracket_name, crb_ring_bracket, crb_p_minimum_ring_name,
	      crb_p_minimum_ring);
      else if crb_ring_bracket > 7
      then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The specified ^a bracket, ^d, is too high.
It must be less than or equal to 7.", crb_p_ring_bracket_name, crb_ring_bracket);

      return (crb_ring_bracket);
   end CONVERT_RING_BRACKET;
%page;
%include dm_file_create_info;
%page;
%include dm_tm_modes;
   end create_dm_file;




		    cv_dmcf.pl1                     04/09/85  1537.6r w 04/08/85  1128.0       75789



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

/* format: ^indcom */

/* DESCRIPTION:
   cv_dmcf - command to convert a data management (system) configuration file
   into table form.  although the table will have the suffix "dmct" when
   installed, the suffix is to be dropped, and the daemon will look for a
   segment called "dm_system_configuration".

   Usage:
	cv_dmcf <config_file_path>
*/
/* HISTORY:

Written by M. Pandolf, 03/01/83.
Modified:
05/29/84 by Lindsey L. Spratt:  Changed to use version 2 dm_system_config.
            Various minor enhancements; use initiate_file_ and
            terminate_file_, terminate all segments initiated by this command,
            delete the table segment when exiting due to an error, use
            suffixed_name_ instead of inline code, make the format standard.
12/10/84 by R. Michael Tague:  Changed to use ERROR_RETURN in place of com_err_
            & ERROR_RETURN, fixed up things a bit.
*/
/* format: style2,ind3 */
%page;
cv_dmcf:
   procedure () options (variable);

/* START OF DECLARATIONS */

/* Automatic */

      dcl	    argp		       pointer;		/* ptr to command line arg */
      dcl	    argl		       fixed bin (21);	/* length of command line arg */
      dcl	    code		       fixed bin (35);	/* status code */
      dcl	    dirname	       char (168);		/* dir of config file */
      dcl	    input_entryname	       char (32);		/* name of config file */
      dcl	    output_entryname       char (32);		/* name of table */
      dcl	    table_segment_was_created
			       bit (1) aligned init ("0"b);
      dcl	    bc		       fixed bin (24);	/* bit count of config file */
      dcl	    filep		       pointer init (null ());/* pointer to config file */
      dcl	    my_area	       area;		/* automatic area file config table */
      dcl	    tablep	       pointer init (null ());/* pointer to config table */

/* Static, External */

      dcl	    (
	    error_table_$translation_failed,
	    error_table_$sameseg,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) ext static;

/* Constant */

      dcl	    ME		       char (32) internal static options (constant) init ("cv_dmcf");
      dcl	    (
	    INPUT_SUFFIX	       init ("dmcf"),
	    OUTPUT_SUFFIX	       init ("dmct")
	    )		       char (4) internal static options (constant);

      dcl	    LONG_ERRORS	       bit (1) aligned internal static options (constant) init ("1"b);
      dcl	    (
	    FORCE_DELETE	       init ("1"b),
	    NO_QUERY	       init ("0"b),
	    NO_DIR	       init ("0"b),
	    SEG		       init ("1"b),
	    NO_LINK	       init ("0"b),
	    CHASE		       init ("1"b)
	    )		       unaligned bit (1) internal static options (constant);
        dcl     (NO_PAD, NO_NL)	init ("0"b) bit (1) aligned
				internal static options (constant);

/* Based */

      dcl	    arg		       char (argl) based (argp);

/* Entry */

      dcl	    com_err_	       entry () options (variable);
dcl cu_$arg_list_ptr entry (ptr);
      dcl	    cu_$arg_ptr	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
      dcl	    delete_$ptr	       entry (ptr, bit (36) aligned, char (*), fixed bin (35));
      dcl	    dm_translate_system_config_
			       entry (ptr, fixed bin (21), bit (1) aligned, ptr, ptr, fixed bin (35));
      dcl	    expand_pathname_$add_suffix
			       entry (char (*), char (*), char (*), char (*), fixed bin (35));
      dcl	    get_wdir_	       entry () returns (char (168));
      dcl	    initiate_file_	       entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
      dcl	    initiate_file_$create  entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24),
			       fixed bin (35));
   dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char(*), fixed bin(21), bit(1) aligned, bit(1) aligned);
dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));
      dcl	    suffixed_name_$new_suffix
			       entry (char (*), char (*), char (*), char (32), fixed bin (35));
      dcl	    terminate_file_	       entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* Builtin */

      dcl	    (addr, divide, empty, size, null)
			       builtin;

/* Conditions */

      dcl	    cleanup	       condition;

/* END OF DECLARATIONS */


      on cleanup call ERROR_FINISH ();

      call cu_$arg_ptr (1, argp, argl, code);
      if code ^= 0
      then
         	  call ERROR_RETURN (code, "^/Usage is: cv_dmcf <config_file_path>");

      call expand_pathname_$add_suffix (arg, INPUT_SUFFIX, dirname, input_entryname, code);
      if code ^= 0
      then
         	  call ERROR_RETURN (code, "Supplied pathname was: ^a.", arg);

/* try to get a pointer to the config file */

      call initiate_file_ (dirname, input_entryname, R_ACCESS, filep, bc, code);
      if filep = null ()
      then
         	  call ERROR_RETURN (code, "Error occurred while referencing ^a.", pathname_ (dirname, input_entryname));

/* get the config table */

      call
         dm_translate_system_config_ (filep, divide (bc, 9, 21, 0), LONG_ERRORS, addr (my_area), dm_system_config_ptr,
         code);
      if code ^= 0
      then
         	  call ERROR_RETURN (error_table_$translation_failed);

      if dm_system_config.version ^= DM_CONFIG_VERSION_2
      then
	  call ERROR_RETURN (error_table_$unimplemented_version,
	     "^/The dm_translate_system_config_ module did not produce the expected
version of the dm_system_config structure. 
The expected version was ""^a"" and the received version was ""^a"".", dm_system_config.version, DM_CONFIG_VERSION_2);
					/* copy the structure into a segment */

      call suffixed_name_$new_suffix (input_entryname, INPUT_SUFFIX, OUTPUT_SUFFIX, output_entryname, code);
      if code ^= 0
      then
         	  call ERROR_RETURN (code, "^/Unable to make the output file name from the input file name.");

      call
         initiate_file_$create (get_wdir_ (), output_entryname, RW_ACCESS, tablep, table_segment_was_created, (0), code);

      if tablep = null () then
	 call ERROR_RETURN (code, "Unable to create output segment.");
      else if tablep = filep
      then
         	  call ERROR_RETURN (error_table_$sameseg, "Using the configuration file to store the configuration table.");
      else
      tablep -> dm_system_config = dm_system_config_ptr -> dm_system_config;

      call FINISH ();
MAIN_RETURN:
      return;

FINISH:
   proc ();
      if filep ^= null ()
      then call terminate_file_ (filep, 0, TERM_FILE_TERM, code);

      if tablep ^= null ()
      then call terminate_file_ (tablep, size (dm_system_config) * 36, TERM_FILE_TRUNC_BC_TERM, code);
   end FINISH;

ERROR_FINISH:
   proc ();
      if tablep ^= null ()
      then
         do;
	  if table_segment_was_created
	  then call delete_$ptr (tablep, FORCE_DELETE || NO_QUERY || NO_DIR || SEG || NO_LINK || CHASE, ME, code);
	  else call terminate_file_ (tablep, 0, TERM_FILE_TERM, code);
	  tablep = null ();
         end;
      call FINISH;

   end ERROR_FINISH;

ERROR_RETURN:
        proc () options (variable);
        dcl     er_arg_count		fixed bin;
        dcl     er_arg_list_ptr	ptr;
        dcl     er_based_error_code	fixed bin (35) based;
        dcl     er_code		fixed bin (35);
        dcl     1 er_err_msg_struc,
	        2 length		fixed bin (21),
	        2 string		char (1024);
        dcl     er_err_msg		varying char (1024)
				based (addr (er_err_msg_struc));

        call ERROR_FINISH ();
        call cu_$arg_list_ptr (er_arg_list_ptr);
        if er_arg_list_ptr -> arg_list.arg_count > 0 then
	      do;
	      if er_arg_list_ptr -> arg_list.arg_count > 2 then
		    call ioa_$general_rs (er_arg_list_ptr, 3, 4,
		        er_err_msg_struc.string, er_err_msg_struc.length,
		        NO_PAD, NO_NL);
	      else
		    er_err_msg = "";
	      call com_err_ (er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_based_error_code, ME, er_err_msg);
	      end;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
/* Include Files */
%page;
%include access_mode_values;
%page;
%include arg_list;
%page;
%include dm_system_config;
%page;
%include terminate_file;
   end cv_dmcf;




		    delete_dm_file_.pl1             01/04/85  0952.6re  01/03/85  1150.2       25164



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

delete_dm_file_: proc (A_dir_name, A_entry_name, A_code);

/* DESCRIPTION:

   Deleting primitive for DM files, with interface like hcs_$delentry_file.
*/

/* HISTORY:

Written by Steve Herbst, 03/29/83.
Modified:
10/15/84 by Steve Herbst: Changed in response to audit comments.
12/05/84 by Matthew Pierret: Changed to return the code
            dm_error_$delete_pending_transaction if the deletion was
            successful but the transaction was not committed because
            this routine did not begin the transaction.
12/07/84 by Lindsey L. Spratt:  Changed
            error_table_$delete_pending_transaction to dm_error_$=.
*/

/* Parameters */

dcl  (A_dir_name, A_entry_name) char (*);
dcl  A_code fixed bin (35);

/* Automatic */

dcl  txn_id bit (36) aligned;
dcl  (begin_code, code) fixed bin (35);

/* External */

dcl  dm_error_$delete_pending_transaction fixed bin (35) ext;
dcl  dm_error_$transaction_in_progress fixed bin (35) ext;

/* Entries */

dcl  file_manager_$delete entry (char (*), char (*), fixed bin (35));
dcl  transaction_manager_$abort_txn entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$begin_txn entry (fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$commit_txn entry (bit (36) aligned, fixed bin (35));

/* Conditions */

dcl  cleanup condition;
%page;
	A_code, begin_code, code = 0;
	txn_id = "0"b;

	on cleanup call FINISH ();

	call transaction_manager_$begin_txn (TM_NORMAL_MODE, "0"b, txn_id, begin_code);
	if begin_code ^= 0 & begin_code ^= dm_error_$transaction_in_progress then call ERROR_RETURN (begin_code);
						/* OK to use existing txn if there is one */

	call file_manager_$delete (A_dir_name, A_entry_name, code);

	if code ^= 0 then call ERROR_RETURN (code);
	else if begin_code = dm_error_$transaction_in_progress then
	     A_code = dm_error_$delete_pending_transaction;
	else do;
	     call transaction_manager_$commit_txn (txn_id, code);
	     if code ^= 0 then call ERROR_RETURN (code);
	     else A_code = 0;
	end;

RETURN:
	return;
%page;
ERROR_RETURN: proc (P_code);

dcl  P_code fixed bin (35);

	A_code = P_code;
	call FINISH;
	go to RETURN;

end ERROR_RETURN;


FINISH: proc ();

	if txn_id ^= "0"b & begin_code ^= dm_error_$transaction_in_progress then
	     call transaction_manager_$abort_txn (txn_id, 0);

end FINISH;
%page;
%include dm_tm_modes;


end delete_dm_file_;




		    dm_admin_util_.alm              03/06/85  0751.0re  03/05/85  0755.9       13527



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
" 	This is the main transfer vector for the administrative Data
"    Management primitives.
"
" HISTORY:
" Written by Matthew Pierret, 09/17/84.
" Modified:
" 11/22/84 by Lee A. Newcomb:  Removed the obsolete set_aim_dir,
"	    create_aim_control_seg, and set_bootload_dir entries.
" 11/27/84 by Stanford S. Cox: Added copy_log, set_journal_stamps,
"	    and send*, chg transfer macro to always use dm_ prefix.
" 01/16/84 by R. Michael Tague: Removed send_(noop flush_journals
"             leist_ref_names process_command terminate_segno) and 
"	    added send_new_process_notifies and kill_txn.  Alphabetized
"	    entries.
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
     
	name	dm_admin_util_

	macro	transfer
	entry	&1
&1:
	call6	dm_admin_gate_$dm_&1

	&end

	transfer 	copy_log

	transfer	schedule_shutdown

          transfer  send_adjust_process_id

          transfer  send_adjust_tdt

          transfer  send_adjust_tdt_entry

          transfer  send_adjust_txn

	transfer  send_kill_txn

          transfer  send_new_proc

	transfer	send_new_process_notifies

          transfer  send_shutdown

	transfer	set_journal_stamps

	end




		    dm_check_configuration_.pl1     01/04/85  0952.6re  01/03/85  1150.2       28953



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

/* DESCRIPTION:

         This  program  validates  the  various fields and indicators in a DM
     configuration file.  The check is the checksum stored  in  the  file  vs.
     the  calculated  checksum.    This  should  be  expanded later to include
     validity checking on the various fields and indicators stored in the file
     to save the individual initialization programs from having to  check  the
     values.
*/

/* HISTORY:

Written by L. A. Newcomb, 05/09/83.
Modified:
05/29/84 by Lindsey L. Spratt:  Converted to use version 2 of
            dm_system_config.
*/
/* format: style2,ind3 */
%page; /* format: style4,indattr,ifthenstmt,ifthen,^indcomtxt,idind33 */

dm_check_configuration_:
     proc (p_dm_system_config_ptr);

/* START OF DECLARATIONS */

dcl						/* Parameter */
     p_dm_system_config_ptr	        ptr;		/* Loc. of DM config file. */

dcl						/* Automatics */
     calculated_config_checksum       fixed bin (35)
			        automatic;

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

dcl						/* Constant */
     myname		        init ("dm_check_configuration_") char (32) varying
			        internal static options (constant);

dcl						/* Entries */
     dm_gen_checksum_	        entry (ptr, fixed bin (18)) returns (fixed bin (35)),
     sub_err_		        entry () options (variable);

dcl  (						/* Status Codes */
     dm_error_$system_config_file_checksum_err,
     error_table_$unimplemented_version
     )			        fixed bin (35) external static;

/* END OF DECLARATIONS */
%page;
/* copy parameter to local for ease of use. */

	dm_system_config_ptr = p_dm_system_config_ptr;

/* first check the version */

	call CHECK_VERSION (dm_system_config.version, DM_CONFIG_VERSION_2, "dm_system_config");

/* now try the checksum if we get this far */

	calculated_config_checksum = dm_gen_checksum_ (dm_system_config_ptr, size (dm_system_config_info) - 1);
	if calculated_config_checksum ^= dm_system_config.checksum then
	     call sub_err_ (dm_error_$system_config_file_checksum_err, myname, ACTION_CANT_RESTART, null (), 0,
		"Config file checksum = ^d, generated checksum = ^d.",
		dm_system_config.checksum, calculated_config_checksum);

	return;
%page;
CHECK_VERSION:
     proc (p_received_version, p_expected_version, p_structure_name);
dcl  (						/* Parameters */
     p_received_version	        char (8) aligned,
     p_expected_version	        char (8) aligned,
     p_structure_name	        char (*)
     )			        parameter;

	if p_received_version ^= p_expected_version then
	     call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
		"^/Expected version ^a of the ^a structure.
Received version ^a instead.", p_expected_version, p_structure_name, p_received_version);

     end CHECK_VERSION;
%page;
%include dm_system_config;
%page;
%include sub_err_flags;
     end dm_check_configuration_;




		    dm_daemon_util_.alm             04/24/85  1016.3re  04/24/85  0802.8       19206



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
" 	This is the main transfer vector for the miscellaneous Data
"    Management primitives that are supposed to be used from the DM Daemon.
"
"
" HISTORY:
" Written by Lee A. Newcomb, 08/02/84.
" Modified:
" 10/01/84 by Lee A. Newcomb: Added $schedule_shutdown (replacing
"	    $start_shutdown), $begin_shutdown, and $set_shutdown_info.
"	    Deleted $shutdown_warning and $user_shutdown.
" 11/28/84 by Stanford S. Cox: Added cp, find_log, get_daemon_info,
"             initialize_system, and log_message.
" 12/05/84 by R. Michael Tague: fixed bump_users TV.
" 12/06/84 by R. Michael Tague: added $unset_shutdown_time, $request, $log,
"             $logout, and $new_proc.
" 04/10/85 by Lee A. Newcomb: Removed the obsolete $cp and $find_log.
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
     
	name	dm_daemon_util_

	macro	transfer
	entry	&1
&1:
	call6	&2

	&end

	transfer	begin_shutdown,dm_dmn_system_shutdown_$begin_shutdown

	transfer	bump_users,dm_dmn_system_shutdown_$bump_users

	transfer	get_daemon_info,dm_daemon_gate_$dm_get_daemon_info

	transfer	get_daemon_logout_time,dm_daemon_gate_$dm_get_daemon_logout_time

	transfer	get_user_bump_time,dm_daemon_gate_$dm_get_user_bump_time

	transfer	initialize_system,dm_daemon_gate_$dm_initialize_system

	transfer  log,dm_dmn_requests_$log

	transfer	log_message,dm_daemon_gate_$dm_log_message

	transfer  logout,dm_dmn_requests_$logout

	transfer  new_proc,dm_dmn_requests_$new_proc

	transfer  request,dm_dmn_requests_$request

	transfer	schedule_shutdown,dm_dmn_system_shutdown_$schedule

	transfer	set_shutdown_info,dm_daemon_gate_$dm_set_shutdown_info

	transfer	set_system_state,dm_daemon_gate_$dm_set_system_state

	transfer  unset_shutdown_timers,dm_dmn_system_shutdown_$unset_shutdown_timers

			         
	end




		    dm_display_version.pl1          04/24/85  1016.3re  04/24/85  0802.8       33327



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

This command displays the version of the Data Management System software currently
in use by the executing process.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 01/24/85.
Modified:
02/15/85 by Lindsey L. Spratt:  Added comparison of
            dm_misc_util_$get_system_version with the
            dm_system_data_template_$system_software_version.
03/19/85 by S. Cox: Added dm_not_available_ handler.
04/16/85 by Lindsey L. Spratt:  Added a pnotice.
*/
/* format: style2,ind3 */
%page;
dm_display_version:
   proc ();

/* START OF DECLARATIONS */
/* Automatic */

      dcl	    arg_list_ptr	       ptr init (null);
      dcl	    bootload_version       char (8) aligned init ("");
      dcl	    code		       fixed bin (35);
      dcl	    dm_ring_version	       char (8) aligned init ("");
      dcl	    number_of_args	       fixed bin;
      dcl	    sci_ptr	       ptr init (null);
      dcl	    user_ring_version      char (8) aligned init (dm_system_data_template_$system_software_version);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Condition */

      dcl	    (cleanup, dm_not_available_)
			       condition;

/* Constant */

      dcl	    myname	       init ("dm_display_version") char (18) internal static options (constant);

/* Entry */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    dm_misc_util_$get_system_version
			       entry (char (8) aligned, char (8) aligned);
      dcl	    ioa_		       entry () options (variable);
      dcl	    ssu_$abort_line	       entry () options (variable);
      dcl	    ssu_$arg_count	       entry (ptr, fixed bin);
      dcl	    ssu_$destroy_invocation
			       entry (ptr);
      dcl	    ssu_$standalone_invocation
			       entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

/* External */

      dcl	    dm_system_data_template_$system_software_version
			       char (8) aligned external;
      dcl	    dm_error_$system_not_initialized
			       fixed bin (35) ext static;
      dcl	    error_table_$badopt    fixed bin (35) external;

/* END OF DECLARATIONS */
      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on dm_not_available_ call ssu_$abort_line (sci_ptr, dm_error_$system_not_initialized);

      on cleanup call CLEANUP ();

      call ssu_$arg_count (sci_ptr, number_of_args);

      if number_of_args > 0
      then call ssu_$abort_line (sci_ptr, error_table_$badopt, "This command takes no arguments.");

      call dm_misc_util_$get_system_version (bootload_version, dm_ring_version);

      if bootload_version = dm_ring_version & bootload_version = user_ring_version
      then call ioa_ ("Data Management System version is ""^a"".", bootload_version);
      else call ioa_ ("Data Management System version at DM bootload time was ""^a"",
the version of DM in use by this process in the user ring is ""^a"",
the version of DM in use by this process in the DM ring is ""^a"".", bootload_version, user_ring_version,
	      dm_ring_version);

      call FINISH ();

MAIN_RETURN:
      return;
%page;
ABORT_ENTRY:
   procedure ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;



CLEANUP:
   procedure ();
      call FINISH ();
   end CLEANUP;

FINISH:
   proc ();
      call ssu_$destroy_invocation (sci_ptr);
   end FINISH;

   end dm_display_version;




		    dm_dmn_requests_.pl1            07/13/88  1122.6r w 07/13/88  0937.9      199449



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

/* DESCRIPTION:
This program is a collection of utility entries for the Data Management
Daemon.  The most important of these entries is the $request entry.  This
entry is the object of the event call channel that all Daemon requests
are made over.  There are entries to logout and new_proc the Daemon
and an entry for logging.

This procedure was originally written by Mike Pandolf.  Most of the 
$request entry was taken from the now defunct dmsd_listener_ program,
also written by Mike Pandolf.
*/

/* HISTORY:
Written by R. Michael Tague, 11/23/84.
Modified:
12/06/84 by R. Michael Tague: Changed program name from dmsd_util_.
12/10/84 by R. Michael Tague: Changed string for alarm wakeups, is "alarm___".
12/11/84 by R. Michael Tague: Removed error code from the $adjust_tdt call.
01/16/85 by R. Michael Tague: Fixed a variety of small items for auditing.
01/22/85 by R. Michael Tague: Added the kill_txn request.
03/18/85 by Steve Herbst: Removed "TDT adjusted." log message.
*/


/****^  HISTORY COMMENTS:
  1) change(87-04-27,GDixon), approve(87-07-08,MCR7741),
     audit(87-07-08,Hartogs), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
                                                   END HISTORY COMMENTS */


/* format: style5,^indcomtxt */
log:
        proc () options (variable);

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

        dcl     arg_list_ptr		ptr;
        dcl     group_id		char (32);
        dcl     myname		char (32);
        dcl     request_type		fixed bin (17);
        dcl     sender_id		bit (36) aligned;

        dcl     logout_current_system_state
				char (4) aligned;

        dcl     1 logout_info		aligned,
	        2 version		fixed bin init (0),
	        2 hold		bit (1) unal init ("0"b),
	        2 brief		bit (1) unal init ("0"b),
	        2 pad		bit (34) unal init ((34)"0"b);

        dcl     1 new_proc_info	aligned,
	        2 version		fixed bin init (1),
	        2 change_auth	bit (1) unal init ("0"b),
	        2 pad		bit (35) unal init ((35)"0"b),
	        2 new_auth		bit (72) aligned;

/* Builtin */

        dcl     (addr, null, rtrim, substr)
				builtin;

/* Constant */

        dcl     NEVER_SET		fixed bin (71) init (-1) int
				static options (constant);
        dcl     SYSTEM_CTL_DIR	char (4) init (">sc1") int
				static options (constant);

/* Entry */

        dcl     cu_$arg_list_ptr	entry (ptr);
        dcl     dm_daemon_util_$get_daemon_info
				entry (ptr);
        dcl     dm_daemon_util_$log	entry options (variable);
        dcl     dm_daemon_util_$log_message
				entry (ptr);
        dcl     dm_daemon_util_$new_proc
				entry ();
        dcl     dm_daemon_util_$schedule_shutdown
				entry ();
        dcl     dm_daemon_util_$set_system_state
				entry (char (4) aligned);
        dcl     dm_misc_util_$is_process_using_dm
				entry returns (bit (1) aligned);
        dcl     dm_misc_util_$get_begin_shutdown_time
				entry returns (fixed bin (71));
        dcl     dm_misc_util_$get_system_state
				entry returns (char (4) aligned);
        dcl     hcs_$initiate		entry (char (*), char (*), char (*),
				fixed bin (1), fixed bin (2), ptr,
				fixed bin (35));
        dcl     terminate_process_	entry (char (*), ptr);
        dcl     timer_manager_$reset_alarm_wakeup
				entry (fixed bin (71));
        dcl     timer_manager_$alarm_wakeup
				entry (fixed bin (71), bit (2),
				fixed bin (71));
        dcl     transaction_manager_$adjust_process_id
				entry (bit (36) aligned, fixed bin (35))
				;
        dcl     transaction_manager_$adjust_tdt
				entry ();
        dcl     transaction_manager_$adjust_tdt_entry
				entry (bit (36) aligned, fixed bin,
				fixed bin (35));
        dcl     transaction_manager_$dm_system_in_use
				entry returns (bit (1) aligned);
        dcl     transaction_manager_$ips_wakeup
				entry (char (*), bit (36) aligned);
        dcl     transaction_manager_$kill_txn
				entry (bit (36) aligned, fixed bin (35))
				;

/* External */

        dcl     dm_error_$process_not_found
				fixed bin (35) ext;
        dcl     dm_request_action_$adjust_process_id
				fixed bin (17) ext;
        dcl     dm_request_action_$adjust_tdt
				fixed bin (17) ext;
        dcl     dm_request_action_$adjust_tdt_entry
				fixed bin (17) ext;
        dcl     dm_request_action_$adjust_txn
				fixed bin (17) ext;
        dcl     dm_request_action_$kill_txn
				fixed bin (17) ext;
        dcl     dm_request_action_$new_proc
				fixed bin (17) ext;
        dcl     dm_request_action_$new_process_notifications
				fixed bin (17) ext;
        dcl     dm_request_action_$shutdown
				fixed bin (17) ext;

/* Static */

        dcl     request_idle_time_in_seconds
				fixed bin (71) init (NEVER_SET);

/* These are pointers to the answer table, the absentee user table, */
/* and the daemon user table. */

        dcl     static_ansp		ptr init (null ()) int static;
        dcl     static_autp		ptr init (null ()) int static;
        dcl     static_dutp		ptr init (null ()) int static;

/* END OF DECLARATIONS */

/* *************************************************************************
   * dm_dmn_requests_$log - This entry point passes its argument pointer   *
   * to $log_messages so that the options (variable) can be carried	     *
   * through a gate. This entry is the main procedure entry for this	     *
   * module.						     *
   ************************************************************************* */

        myname = "dm_dmn_requests_$log";
        call cu_$arg_list_ptr (arg_list_ptr);
        call dm_daemon_util_$log_message (arg_list_ptr);
        call RETURN;
%page;
/* *************************************************************************
   * dm_dmn_requests_$logout - This entry is called by the Daemon to       *
   * logout the Daemon's process.  Just before actually logging out	     *
   * a check is made to see if we are currently in the process of shutting *
   * down DM.  If we are and no one is left in the system, the state is    *
   * set to DM_SYSTEM_STATE_NORMAL_SHUTDOWN. The terminate_process_	     *
   * procedure should never return.				     *
   ************************************************************************* */

logout:
        entry ();

        myname = "dm_dmn_requests_$logout";
        if dm_misc_util_$is_process_using_dm () then
	      do;
	      logout_current_system_state = dm_misc_util_$get_system_state ();
	      if logout_current_system_state = DM_SYSTEM_STATE_SHUTDOWN_BEGUN
		| logout_current_system_state
		= DM_SYSTEM_STATE_SHUTDOWN_BUMP_USERS then
		    if ^transaction_manager_$dm_system_in_use () then
			  call dm_daemon_util_$set_system_state (
			      DM_SYSTEM_STATE_NORMAL_SHUTDOWN);
	      end;
        call terminate_process_ ("logout", addr (logout_info));
        call RETURN;
%page;
/* *************************************************************************
   * dm_dmn_requests_$new_proc - This entry is called by the Daemon	     *
   * overseer to get a new process.  This may be called due to an operator *
   * request or because an error was encountered.  The terminate_process_  *
   * procedure should never return.				     *
   ************************************************************************* */

new_proc:
        entry ();

        myname = "dm_dmn_requests_$new_proc";
        call terminate_process_ ("new_proc", addr (new_proc_info));
        call RETURN;
%page;
/* *************************************************************************
   * dm_dmn_requests_$request - This entry handles all Daemon requests     *
   * including those made by the Answering Service to adjust_process_id    *
   * for processes that have terminated and the Idle timer request of	     *
   * adjust_tdt.  This entry is called as the object of an event call	     *
   * channel.						     *
   ************************************************************************* */

request:
        entry (event_call_info_ptr);

        myname = "dm_dmn_requests_$request";
        dm_request_message_ptr = addr (event_call_info.message);
        sender_id = event_call_info.sender;
        group_id = GET_PROCESS_GROUP (sender_id);
        call RESET_IDLE_TIMER (event_call_info.channel_id);
        if dm_alarm_message = "alarm___" then
	      call ALARM_WAKEUP ();
        else
	      do;
	      request_type = dm_request_message.action_type;
	      if request_type = dm_request_action_$adjust_process_id then
		    call ADJUST_PROCESS_ID ();
	      else if request_type = dm_request_action_$adjust_tdt then
		    call ADJUST_TDT ();
	      else if request_type = dm_request_action_$adjust_tdt_entry then
		    call ADJUST_TDT_ENTRY ();
	      else if request_type = dm_request_action_$adjust_txn then
		    call ADJUST_TXN ();
	      else if request_type = dm_request_action_$kill_txn then
		    call KILL_TXN ();
	      else if request_type = dm_request_action_$new_proc then
		    call NEW_PROC ();
	      else if request_type
		= dm_request_action_$new_process_notifications then
		    call NEW_PROCESS_NOTIFICATIONS ();
	      else if request_type = dm_request_action_$shutdown then
		    call SHUTDOWN ();
	      else
		    call dm_daemon_util_$log (LOG_SV,
		        "Unknown Daemon request type: ^i, from ^w (^a).",
		        request_type, sender_id, group_id);
	      end;
        call RETURN;

MAIN_RETURN:
        return;
%page;
/* *************************************************************************
   * ALARM_WAKEUP - This routine is invoked by an idle timeout request.    *
   ************************************************************************* */

ALARM_WAKEUP:
        proc ();

        call dm_daemon_util_$log (LOG_SV, "Idle timeout request by ^w, (^a).",
	  sender_id, group_id);
        call transaction_manager_$adjust_tdt ();
        end ALARM_WAKEUP;
%page;
/* *************************************************************************
   * ADJUST_PROCESS_ID - Request to adjust the TDT based on a supplied     *
   * process_id.  This request is logged if it does not come from the      *
   * the Initializer.  The Answering Service sends this request as a	     *
   * process termination notification.				     *
   ************************************************************************* */

ADJUST_PROCESS_ID:
        proc ();
        dcl     api_code		fixed bin (35);
        dcl     INITIALIZER_USER_NAME	char (11) init ("Initializer")
				internal static options (constant);

        if substr (group_id, 1, 11) ^= INITIALIZER_USER_NAME then
	      do;
	      call dm_daemon_util_$log (LOG_SV,
		"ADJUST_PROCESS_ID ^w requested by ^w (^a).",
		dm_adjust_process_id_message.process_id, sender_id,
		group_id);
	      call transaction_manager_$adjust_process_id
		((dm_adjust_process_id_message.process_id), api_code);
	      if api_code ^= 0 then
		    call dm_daemon_util_$log (LOG_SV, api_code, myname,
		        "Transaction manager could not adjust process id.");
	      end;
        else
	      do;
	      call transaction_manager_$adjust_process_id
		((dm_adjust_process_id_message.process_id), api_code);
	      if api_code ^= 0 & api_code ^= dm_error_$process_not_found then
		    call dm_daemon_util_$log (LOG_SV, api_code, myname,
		        "Transaction manager could not adjust process id.");
	      end;
        end ADJUST_PROCESS_ID;
%page;
/* *************************************************************************
   * ADJUST_TDT - Adjust the TDT table.				     *
   ************************************************************************* */

ADJUST_TDT:
        proc ();

        call dm_daemon_util_$log (LOG_SV, "ADJUST TDT for ^w (^a).", sender_id,
	  group_id);
        call transaction_manager_$adjust_tdt ();
        call dm_daemon_util_$log (LOG_SV, "TDT successfully adjusted.");
        end ADJUST_TDT;
%page;
/* *************************************************************************
   * ADJUST_TDT_ENTRY - Adjust the TDT table for a specified entry, an     *
   * offset into the table.					     *
   ************************************************************************* */

ADJUST_TDT_ENTRY:
        proc ();
        dcl     ate_code		fixed bin (35);

        call dm_daemon_util_$log (LOG_SV,
	  "ADJUST_TDT_ENTRY (index = ^i) requested by ^w (^a).",
	  dm_adjust_txn_message.transaction_index, sender_id, group_id);
        call transaction_manager_$adjust_tdt_entry
	  ((dm_adjust_txn_message.transaction_id),
	  (dm_adjust_txn_message.transaction_index), ate_code);
        if ate_code ^= 0 then
	      call dm_daemon_util_$log (LOG_SV, ate_code, myname,
		"TDT entry could not be adjusted.");
        else
	      call dm_daemon_util_$log (LOG_SV,
		"TDT entry successfully adjusted.");
        end ADJUST_TDT_ENTRY;
%page;
/* *************************************************************************
   * ADJUST_TXN - Adjust the TDT table given a transaction id.	     *
   ************************************************************************* */

ADJUST_TXN:
        proc ();
        dcl     at_code		fixed bin (35);

        call dm_daemon_util_$log (LOG_SV,
	  "ADJUST_TXN (index = ^i) requested by ^w (^a).",
	  dm_adjust_txn_message.transaction_index, sender_id, group_id);
        call transaction_manager_$adjust_tdt_entry
	  ((dm_adjust_txn_message.transaction_id),
	  (dm_adjust_txn_message.transaction_index), at_code);
        if at_code ^= 0 then
	      call dm_daemon_util_$log (LOG_SV, at_code, myname,
		"Transaction could not be adjusted");
        else
	      call dm_daemon_util_$log (LOG_SV,
		"Transaction successfully adjusted.");
        end ADJUST_TXN;
%page;
/* *************************************************************************
   * GET_PROCESS_GROUP - This function returns a string which is the	     *
   * caller process' group_id (user.project.tag).  If the group id cannot  *
   * be determined, then "UNABLE TO GET GROUP ID" is returned.	     *
   ************************************************************************* */

GET_PROCESS_GROUP:
        proc (gpg_process_id) returns (char (32));
        dcl     gpg_process_id	bit (36) aligned;
        dcl     gpg_code		fixed bin (35);
        dcl     gpg_entry_no		fixed bin;
        dcl     INTERACTIVE_USER_TABLE	char (32) init ("answer_table")
				internal static options (constant);
        dcl     DAEMON_USER_TABLE	char (32)
				init ("daemon_user_table")
				internal static options (constant);
        dcl     ABSENTEE_USER_TABLE	char (32)
				init ("absentee_user_table")
				internal static options (constant);

        if static_ansp = null () then
	      call hcs_$initiate (SYSTEM_CTL_DIR, INTERACTIVE_USER_TABLE, "",
		0, 0, static_ansp, gpg_code);
        if static_dutp = null () then
	      call hcs_$initiate (SYSTEM_CTL_DIR, DAEMON_USER_TABLE, "", 0, 0,
		static_dutp, gpg_code);
        if static_autp = null () then
	      call hcs_$initiate (SYSTEM_CTL_DIR, ABSENTEE_USER_TABLE, "", 0,
		0, static_autp, gpg_code);
        ansp = static_ansp;
        autp = static_autp;
        dutp = static_dutp;

        if ansp ^= null () then
	      do gpg_entry_no = 1 to ansp -> anstbl.current_size;
		    utep = addr (anstbl.entry (gpg_entry_no));
		    if utep -> ute.active = NOW_HAS_PROCESS then
			  if utep -> ute.proc_id = gpg_process_id then
				return (rtrim (utep -> ute.person)
				    || "."
				    || rtrim (utep -> ute.project)
				    || ".a");
	      end;

        if autp ^= null () then
	      do gpg_entry_no = 1 to autp -> autbl.current_size;
		    utep = addr (autp -> autbl.entry (gpg_entry_no));
		    if utep -> ute.active ^= NOW_FREE then
			  if utep -> ute.proc_id = gpg_process_id then
				return (rtrim (utep -> ute.person)
				    || "."
				    || rtrim (utep -> ute.project)
				    || ".m");
	      end;

        if dutp ^= null () then
	      do gpg_entry_no = 1 to dutp -> dutbl.current_size;
		    utep = addr (dutp -> dutbl.entry (gpg_entry_no));
		    if utep -> ute.active = NOW_HAS_PROCESS then
			  if utep -> ute.proc_id = gpg_process_id then
				return (rtrim (utep -> ute.person)
				    || "."
				    || rtrim (utep -> ute.project)
				    || ".z");
	      end;

        return ("UNABLE TO GET GROUP ID");
        end GET_PROCESS_GROUP;
%page;
/* *************************************************************************
   * IDLE_TIME_IN_SECONDS - This function returns the the value of the DM  *
   * system parameter that specifies the amount of time between idle	     *
   * timeouts for the Daemon.  The time is converted from minutes to	     *
   * seconds and returned.					     *
   ************************************************************************* */

IDLE_TIME_IN_SECONDS:
        proc () returns (fixed bin);
        dcl     1 itis_daemon_info	aligned like dm_daemon_info;
        dcl     SECONDS_PER_MINUTE	fixed bin init (60) internal
				static options (constant);

        itis_daemon_info.version = DM_DAEMON_INFO_VERSION_1;
        call dm_daemon_util_$get_daemon_info (addr (itis_daemon_info));
        return (SECONDS_PER_MINUTE * itis_daemon_info.wakeup_increment);
        end IDLE_TIME_IN_SECONDS;
%page;
/* *************************************************************************
   * KILL_TXN - Kills (just wipes out) tht specified TDT entry.	     *
   ************************************************************************* */

KILL_TXN:
        proc ();
        dcl     kt_code		fixed bin (35);

        call dm_daemon_util_$log (LOG_SV,
	  "KILL_TXN (ID = ^i) requested by ^w (^a).",
	  dm_kill_txn.transaction_id, sender_id, group_id);
        call transaction_manager_$kill_txn ((dm_kill_txn.transaction_id),
	  kt_code);
        if kt_code ^= 0 then
	      call dm_daemon_util_$log (LOG_SV, kt_code, myname,
		"Transaction could not be killed.");
        else
	      call dm_daemon_util_$log (LOG_SV,
		"Transaction successfully killed.");
        end KILL_TXN;
%page;
/* *************************************************************************
   * NEW_PROC - The new_proc request.  This causes the DM Daemon to	     *
   * execute a new_proc.					     *
   ************************************************************************* */

NEW_PROC:
        proc ();

        call dm_daemon_util_$log (LOG_SV, "NEW_PROC from process ^w (^a).",
	  sender_id, group_id);
        call dm_daemon_util_$new_proc ();
        end NEW_PROC;
%page;
/* *************************************************************************
   * NEW_PROCESS_NOTIFICATIONS - This request causes the Daemon to send a  *
   * dm_shutdown_scheduled_ IPS signal to the process that made the	     *
   * request.  This is used by per-process initialization in the inner     *
   * ring to cause the IPS signal for the outer ring.		     *
   ************************************************************************* */

NEW_PROCESS_NOTIFICATIONS:
        proc ();
        dcl     DM_SHUTDOWN_SCHEDULED_IPS_NAME
				char (32)
				init ("dm_shutdown_scheduled_")
				internal static options (constant);

        if dm_misc_util_$get_begin_shutdown_time () ^= 0 then
	      call transaction_manager_$ips_wakeup (
		DM_SHUTDOWN_SCHEDULED_IPS_NAME, sender_id);
        end NEW_PROCESS_NOTIFICATIONS;
%page;
/* *************************************************************************
   * RETURN - This is the main return procedure for the several entry      *
   * points.  It does a non-local goto to MAIN_RETURN.		     *
   ************************************************************************* */

RETURN:
        proc ();

        goto MAIN_RETURN;
        end RETURN;
%page;
/* *************************************************************************
   * RESET_IDLE_TIMER - This entry is called whenever a request is	     *
   * processed.  It resets the the idle timer since we aren't idle.  The   *
   * idle timer is set to go off request_idle_time_in_seconds in the       *
   * future.  If the static value request_idle_time_in_seconds has not     *
   * been set before, we set it using the value returned from the          *
   * IDLE_TIME_IN_SECONDS procedure.				     *
   ************************************************************************* */

RESET_IDLE_TIMER:
        proc (rit_p_request_channel);
        dcl     rit_p_request_channel	fixed bin (71);
        dcl     RIT_RELATIVE_SECONDS_REQUEST
				bit (2) init ("11"b) internal
				static options (constant);

        call timer_manager_$reset_alarm_wakeup (rit_p_request_channel);
        if request_idle_time_in_seconds = NEVER_SET then
	      request_idle_time_in_seconds = IDLE_TIME_IN_SECONDS ();
        if request_idle_time_in_seconds > 0 then
	      call timer_manager_$alarm_wakeup (request_idle_time_in_seconds,
		RIT_RELATIVE_SECONDS_REQUEST, rit_p_request_channel);
        end RESET_IDLE_TIMER;
%page;
/* *************************************************************************
   * SHUTDOWN - This request causes the DM system to schedule a shutdown.  *
   ************************************************************************* */

SHUTDOWN:
        proc ();
        call dm_daemon_util_$log (LOG_SV, "SHUTDOWN from process ^w (^a).",
	  sender_id, group_id);
        call dm_daemon_util_$schedule_shutdown ();
        end SHUTDOWN;

%page; %include answer_table;
%page; %include absentee_user_table;
%page; %include dm_daemon_info;
%page; %include daemon_user_table;
%page; %include dialup_values;
%page; %include dm_log_sv_codes;
%page; %include dm_request_message;
%page; %include dm_system_states;
%page; %include event_call_info;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

        end log;




		    dm_dmn_system_shutdown_.pl1     04/24/85  1016.3re  04/24/85  0802.8      126207



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

/* DESCRIPTION:

         This  module  is  used  by the caretaker Daemon of a Data Management
     System (DMS) to do the various steps of  DMS  shutdown  in  the  Daemon's
     login  ring.   There are currently four entries:  $schedule, $begin, 
     $bump_users, and $unset_shutdown_timers.  A fifth entry for logging out
     the Daemon  is  logically  a part  of  DMS shutdown as we will set the DMS
     state to normal shutdown if the DMS is not in use; it is not here because
     of its more general nature.

          $schedule:  The Daemon has received  the  system_shutdown_scheduled_
     IPS  or  a  shutdown  request  over  one  of  its  ipc_ channels.  In the
     system_shutdown_scheduled_ IPS case, it calculates the times the shutdown
     steps would occur, puts these times  in  dm_system_data_,  and  sets  the
     reason  for  shutdown  to  be  "Multics  shutting down @ {time}".  If the
     operator or administrative interfaces  send  the  shutdown  request,  the
     times   and   reason   are  taken  from  the  saved_shutdown*  values  in
     dm_system_data_.

          If  shutdown  has  begun  (see  next  entry),  the new scheduling is
     ignored  and  a  log entry is made.  A set of utility programs is used to
     mediate  between  administratively  set values and default system values;
     this  prevents  the  accidental  setting  of  a  shutdown  past a Multics
     shutdown.   Administratively  set times earlier than times generated from
     the  Multics  down time are NEVER ignored.  If a DMS shutdown has already
     been  scheduled,  but  not begun, then the timers the daemon set up to do
     the remaining steps are cancelled and new ones set up.

	Three  alarm call timers are set up: (1) when to begin shutdown, (2)
     when  to bump users who did not execute DM user shutdown, and (3) when to
     force  logout  the  Daemon  even  if  shutdown has not totally completed.
     After  the above is done, we start sending the dm_shutdown_scheduled_ IPS
     to all current users of the DMS.

          $begin_shutdown: this entry sets the DMS state to "shutdown begun"
     and prevents new transactions from starting.  When this step completes,
     no new user of the DMS will complete per-process initialization.

          $bump_users:  this entry will bump all users  still  active  in  the
     DMS.

          After $bump_users has run, we will wait for the  last  timer  to  go
     off,  adjusting  the  dead  processes that roll in.  If after adjusting a
     daemon process, no users of the DMS (except the caretaker Daemon)  exist,
     the sytem state is set to normal shutdown and the Daemon logs out without
     waiting for the logout timer.

          $unset_shutdown_timers:  this entry gets rid of all timers that may
     have been set.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 04/06/84.
Modified:
07/26/84 by Lee A. Newcomb:  renamed from dm_shutdown_ to
	  dm_dmn_system_shutdown_ to highlight this program's use by a DMS'
	  caretaker Daemon and not users (for the user interface, see
	  transaction_manager_$user_shutdown).  Also changed all entries
	  except $bump_users to do the work they are supposed to.  Removed
	  the $normal_shutdown entry as it is taken care of by
	  dmsd_overseer_$daemon_logout.
09/20/84 by Lee A. Newcomb:  Changed to use the new shutdown_info processing
            methodology, set appropriate timers if a shutdown was really
	  scheduled (not cancelled), and use the new entry
	  transaction_manager_$ips_wakeup_all.
10/28/84 by Lee A. Newcomb:  renamed $begin to $begin_shutdown to match TV
            call.
12/05/84 by R. Michael Tague: changed dmsd_overseer_$daemon_logout to
            dmsd_util_$logout.
12/06/84 by R. Michael Tague: changed dmsd_util_$* to dm_daemon_util_$*,
            added $unset_shutdown_timers, and transaction_manager_$bump_all.
12/10/84 by Lindsey Spratt:  Changed to catch the timer_manager_err condition
	  when resetting the alarm calls (in $unset_shutdown_timers).  This
	  condition is raised if the timer was never set.
12/11/84 by Lee A. Newcomb:  Fixed to send the dm_shutdown_scheduled_ IPS,
	  not dm_shutdown_warning_.
03/20/85 by Steve Herbst:  Changed to log all the schedule times.
03/28/85 by Lindsey Spratt:  Fixed to use dm_misc_util_ and dm_daemon_util_
	  to get the shutdown times instead of referencing dm_system_data_
	  directly.
04/11/85 by Lee A. Newcomb:  To log fact no shutdown was scheduled if shutdown
            times where not set instead of converting a zero time and
            reporting it.
           Added the reason for shutdown to the logged information and added
            new-lines to improve readability.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo,^inddcls,dclind5,idind35,linecom */
%page;
dm_dmn_system_shutdown_$schedule:
   proc ();

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */
dcl  (
     begin_shutdown_time_str		char (32) init (""),
     daemon_logout_time_str		char (32) init (""),
     1 local_shutdown_info		aligned like shutdown_info,
     next_reset_label		label variable,
     saved_ips_mask			bit (36) aligned init ("0"b),
     shutdown_reason		char (64) init (""),
     system_state			char (4) aligned init (""),
     user_bump_time_str		char (32) init (""),
     user_shutdown_time_str		char (32) init (""),
     user_warning_time_str		char (32) init ("")
     )				automatic;

/* Based */
/* Builtin */
dcl  (addr, null, unspec)		builtin;

/* Condition */
dcl  (cleanup, timer_manager_err)	condition;

/* Constant */
/* Entry */
dcl  (
     date_time_			entry (fixed bin (71), char (*)),
     dm_daemon_util_$begin_shutdown	entry (),
     dm_daemon_util_$bump_users	entry (),
     dm_daemon_util_$get_daemon_logout_time
				entry () returns (fixed bin (71)),
     dm_daemon_util_$get_user_bump_time entry () returns (fixed bin (71)),
     dm_daemon_util_$set_shutdown_info	entry (ptr),
     dm_daemon_util_$set_system_state	entry (char (4) aligned),
     dm_daemon_util_$unset_shutdown_timers
				entry (),
     dm_misc_util_$get_begin_shutdown_time
				entry () returns (fixed bin (71)),
     dm_misc_util_$get_shutdown_reason	entry () returns (char (64)),
     dm_misc_util_$get_shutdown_warning_time
				entry () returns (fixed bin (71)),
     dm_misc_util_$get_system_state	entry returns (char (4) aligned),
     dm_misc_util_$get_user_shutdown_time
				entry () returns (fixed bin (71)),
     dm_daemon_util_$log		entry () options (variable),
     dm_daemon_util_$logout		entry (),
     hcs_$reset_ips_mask		entry (bit (36) aligned,
				bit (36) aligned),
     hcs_$set_ips_mask		entry (bit (36) aligned,
				bit (36) aligned),
     timer_manager_$alarm_call	entry (fixed bin (71), bit (2), entry),
     timer_manager_$reset_alarm_call	entry (entry),
     transaction_manager_$begins_off	entry (),
     transaction_manager_$bump_all	entry (),
     transaction_manager_$dm_system_in_use
				entry returns (bit (1) aligned),
     transaction_manager_$ips_wakeup_all
				entry (char (*), bit (1) aligned)
     );

/* External */

/* END OF DECLARATIONS */
%page;
/* dm_dmn_system_shutdown_$schedule: */
/*   proc (); */

/* We have received either the system_shutdown_scheduled_ IPS or a	*/
/* "shutdown" IPC message from the operator or an administrator.	*/

   on cleanup call FINISH ();
   call hcs_$set_ips_mask ("0"b, saved_ips_mask);

/* Must make sure shutdown has not started. Any currently set timers	*/
/* for shutdown are ignored as we have masked all IPS', including the	*/
/* alrm IPS.  We don't want to have a shutdown being scheduled and	*/
/* interrupted part way through; otherwise some of the following	*/
/* might not get done, or done inconsistently.			*/

   system_state = dm_misc_util_$get_system_state ();
   if system_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN then
ALREADY_SHUTDOWN:
      do;
      call dm_daemon_util_$log (INFORM_SV,
	 "DMS is completely shutdown; ignored attempt to shut it down again.")
	 ;
      call RETURN ();
   end ALREADY_SHUTDOWN;
   else if system_state = DM_SYSTEM_STATE_SHUTDOWN_BEGUN
        | system_state = DM_SYSTEM_STATE_SHUTDOWN_BUMP_USERS then
SHUTDOWN_IN_PROGRESS:
      do;
      call dm_daemon_util_$log (INFORM_SV,
	 "DMS has started shutdown (state ^a), attempt to reschedule shutdown ignored.",
	 system_state);
      call RETURN ();
   end SHUTDOWN_IN_PROGRESS;
   else if system_state ^= DM_SYSTEM_STATE_RUNNING then
CANT_SHUTDOWN_NON_RUNNING_SYSTEM:
      do;
      call dm_daemon_util_$log (INFORM_SV,
	 "DMS is not running (state ^a), attempt to schedule shutdown ignored.",
	 system_state);
      call RETURN ();
   end CANT_SHUTDOWN_NON_RUNNING_SYSTEM;
   else
SCHEDULE_NEW_SHUTDOWN:
      do;

/* We must get the most up-to-date shutdown info in dm_system_data_,	*/
/* either by using the administratively set values or the implicit	*/
/* values calculated from the Multics down time.			*/

      unspec (local_shutdown_info) = ""b;
      local_shutdown_info.version = SHUTDOWN_INFO_VERSION_1;/* call will use sub_err_ if error found */
      call dm_daemon_util_$set_shutdown_info (addr (local_shutdown_info));

      call dm_daemon_util_$unset_shutdown_timers ();

      if ^local_shutdown_info.no_time_specified then
SET_NEW_ALARM_TIMERS:
         do;

/* there is a scheduled shutdown the Daemon should do something about	*/
/* at various times.					*/

         call timer_manager_$alarm_call (local_shutdown_info
	    .begin_shutdown_time, "00"b /* abs. usec. */,
	    dm_daemon_util_$begin_shutdown);
         call timer_manager_$alarm_call (local_shutdown_info.user_bump_time,
	    "00"b /* abs. usec. */, dm_daemon_util_$bump_users);
         call timer_manager_$alarm_call (local_shutdown_info
	    .daemon_logout_time, "00"b /* abs. usec. */,
	    dm_daemon_util_$logout);

LOG_SHUTDOWN_INFO:
         do;
	  call date_time_ (dm_misc_util_$get_shutdown_warning_time (),
	       user_warning_time_str);
	  call date_time_ (dm_misc_util_$get_begin_shutdown_time (),
	       begin_shutdown_time_str);
	  call date_time_ (dm_misc_util_$get_user_shutdown_time (),
	       user_shutdown_time_str);
	  call date_time_ (dm_daemon_util_$get_user_bump_time (),
	       user_bump_time_str);
	  call date_time_ (dm_daemon_util_$get_daemon_logout_time (),
	       daemon_logout_time_str);
	  shutdown_reason = dm_misc_util_$get_shutdown_reason ();

	  call dm_daemon_util_$log (INFORM_SV,
	       "DMS shutdown scheduled:^/Reason: ^a^/User warning at ^a,^/begin shutdown at ^a,^/user shutdown at ^a,^/users bumped at ^a,^/Daemon logout at ^a.",
	       shutdown_reason, user_warning_time_str,
	       begin_shutdown_time_str, user_shutdown_time_str,
	       user_bump_time_str, daemon_logout_time_str);
         end LOG_SHUTDOWN_INFO;

      end SET_NEW_ALARM_TIMERS;
      else
LOG_NO_SHUTDOWN_SCHEDULED:
         call dm_daemon_util_$log (INFORM_SV,
	    "DMS shutdown not scheduled due to no scheduled Multics shutdown or administrative action."
	    );

/* Now we send the dm_shutdown_scheduled_ IPS to all current users of */
/* the DMS we are taking care of (unless one of our timers goes off). */
/* We do not optimize the case of the shutdown times not being	*/
/* changed (see dm_set_shutdown_info.pl1 for more commentary).	*/

SEND_DSS_IPS:
      do;
         call transaction_manager_$ips_wakeup_all ("dm_shutdown_scheduled_",
	    ("0"b) /* don't care if DMS in use */);
      end SEND_DSS_IPS;

/* continue on and wait for next timer */

   end SCHEDULE_NEW_SHUTDOWN;

   call RETURN ();

/* end dm_dmn_system_shutdown_$scheduled; */
%page;
dm_dmn_system_shutdown_$begin_shutdown:
   entry ();

/* The begin shutdown timer has gone off.  Prevent new transactions	*/
/* and users and update system state.				*/

   on cleanup call FINISH ();
   call hcs_$set_ips_mask ("0"b, saved_ips_mask);

   call dm_daemon_util_$set_system_state (DM_SYSTEM_STATE_SHUTDOWN_BEGUN);
   call transaction_manager_$begins_off ();

   call RETURN ();

/* end dm_dmn_system_shutdown_$begin_shutdown; */
%page;
dm_dmn_system_shutdown_$bump_users:
   entry ();

   call dm_daemon_util_$set_system_state (DM_SYSTEM_STATE_SHUTDOWN_BUMP_USERS);

/* If the DMS is not being used, the mark the state as finished and	*/
/* logout the DM daemon; the logout call will not return.		*/

   if ^transaction_manager_$dm_system_in_use () then
      call dm_daemon_util_$logout ();			/* goodbye */

   call transaction_manager_$bump_all ();

/* Now wait for logout timer.  At this point, all we should have to	*/
/* do is cleanup dead processes/transactions.			*/

   call RETURN ();

/* end dm_dmn_system_shutdown_$bump_users */
%page;
dm_dmn_system_shutdown_$unset_shutdown_timers:
   entry ();

   on timer_manager_err goto next_reset_label;

   next_reset_label = BUMP_USERS_RESET;
   call timer_manager_$reset_alarm_call (dm_daemon_util_$begin_shutdown);
BUMP_USERS_RESET:
   next_reset_label = LOGOUT_RESET;
   call timer_manager_$reset_alarm_call (dm_daemon_util_$bump_users);
LOGOUT_RESET:
   next_reset_label = DONE_RESETTING;
   call timer_manager_$reset_alarm_call (dm_daemon_util_$logout);
DONE_RESETTING:
   call RETURN ();					/* end dm_dmn_system_shutdown_$unset_shutdown_timers */
%page;
MAIN_RETURN:
   return;
%skip (4);
FINISH:						/* doubles as cleanup handler */
   proc ();

/* reset the IPS mask if it is set. */
   if saved_ips_mask ^= "0"b then
      call hcs_$reset_ips_mask (saved_ips_mask, saved_ips_mask);

   end FINISH;
%skip (4);
RETURN:
   proc ();

   call FINISH ();
   goto MAIN_RETURN;

   end RETURN;
%page;
%include dm_shutdown_spec;
%page;
%include dm_system_states;
%page;
%include dm_log_sv_codes;


   end dm_dmn_system_shutdown_$schedule;




		    dm_error_.alm                   04/02/87  1314.3rew 04/02/87  1300.0      236124



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

"
"	THIS IS NOW IN ALPHABETICAL ORDER - PLEASE KEEP IT SO
"
" Written by Someone, ??/??/82.
" Modified:
" 09/16/82 by M. Pandolf: to add before journal codes.
" 10/07/82 by Roger Lackey: added no_tuple,notup  and 
"	    unsupported_spec_operator,unsspo
" 10/23/82 by Roger Lackey: added invalid_search_spec_type,invspt,
" 10/08/82 by Roger Lackey: added unsup_search_spec_head_type and
"	    unsup_search_spec_range_type and record_col_cursor_only.
" 10/18/82 by Roger Lackey: added  no_tuple_id.
" 10/19/82 by Matthew Pierret: Added relation_not_open, bad_last_key_idx,
"	    collection_not_in_relation, no_element.
" 10/21/82 by Jeffrey D. Ives: Added error codes for file_manager_.
" 11/03/82 by M. Pandolf:  Added bj_journal_in_use.
" 11/05/82 by Roger Lackey:  Added invalid_scope,invscope, and
"	    changed name from vd_error_ to dm_error_
" 11/17/82 by Matthew Pierret:  Added $no_datum.
" 11/19/82 by Lee A. Newcomb:   Added $not_all_bj_opened_after_crash and
"	    $partial_recovery.
" 11/19/82 by M. Pandolf:  Added bj_incomplete_rollback.
" 11/22/82 by M. Pandolf:  Added bj_no_txn.
" 12/03/82 by M. Pandolf:  Added bj_already_adopting.
" 12/08/82 by Lee A. Newcomb:  add code needed by bjm_find_txns_after_crash
"	    and $boot_dir_missing
" 12/09/82 by Lee A. Newcomb:  add bj_first_txn_rec_not_found.
" 12/21/82 by Matthew Pierret:  Added $record_not_found ($norec).
" 01/03/83 by J. Bongiovanni:  Merged in dm_error_table_ and ordered 
"	    alphabetically.
" 01/07/83 by Matthew Pierret:  Added $ci_buffer_not_ci ($cibnotci)
"	    This code is returned by one the collection_manager_'s
"	    buffered entries to indicate that the buffer does not
"	    actually contain a control interval, also added
"	    $programming_error ($progerr).
" 01/19/82 by M. Pandolf:  Added bj_bad_rec_count.
" 01/24/83 by Lindsey Spratt:  Added $bad_parent_thread.
" 01/25/83 by Lindsey Spratt:  Added $tdt_entry_in_use, $keys_out_of_order.
" 02/10/83 by Matthew Pierret: Added $cant_buffer_ci_continuations,
"	    $ci_0_invalid_free, $ci_buffer_too_small, $ci_not_allocated,
"	    $col_is_inconsistent, $no_header_record,
"	    $unimplemented_ci_version.  Removed $ci_buffer_not_ci.
" 03/14/83 by L. A. Newcomb: Defined many codes used by before
"	    journal manager that just haven't been.
" 04/07/83 by M. Pandolf:  Added bj_cant_abort and bj_cant_commit.
" 04/26/83 by Matthew Pierret: Added $tuple_not_found (with synonym
"	    $no_tuple) and added $tuple_not_found_id to $no_tuple_id.
"	    Changed the wording of both messages slightly.
" 04/29/83 by Matthew Pierret: Added $long_return_element.
" 05/03/83 by L. A. Newcomb: added codes needed by bj_pste_(create lock).pl1
"	    and fixed a spelling error.
" 05/04/83 by Jeffrey D. Ives: Added file_path_too_long.
" 05/09/83 by L. A. Newcomb: added system_config_file_checksum_err.
" 06/08/83 by L. A. Newcomb: added bj_illegal_size for bjm_create.pl1.
" 06/08/83 by Matthew Pierret: Added rel_cursor_pos_bad and
"	    rel_cursor_spec_mismatch.
" 10/06/83 by Lindsey Spratt: Added $bad_vector_type, and a short
"	    message for $bad_parent_thread.
" 10/31/83 by M. Pandolf: added bj_invalid_name.
" 11/29/83 by Steve Herbst: added $no_user_dm.
" 03/21/84 by Matthew Pierret: Changed $ci_not_allocated to not
"	    mention collections, as it is now used by file_manager_.
" 04/19/84 by Lindsey Spratt: Added $short_buffer.
" 05/04/84 by Matthew Pierret: Added: $bad_specification_type,
"	    $invalid_cursor_position, $bad_first_key_index,
"	    $bad_leaf_node, $wrong_cursor_type
"	    Removed the un-used codes: $insufficient_room_in_ci,
"	    $invalid_cursor.
" 06/06/84 by Lee Baldwin: Reworded many of the codes' descriptions.
"	    Removed the unused codes. Added the codes: 
"	    index_not_in_relation, invalid_alignment,
"	    nonempty_relation, tdt_entry_not_freed,
"	    unexpected_search_case, unimplemented_data_type.
"	    Renamed the codes named **_bad or *_bad_* to bad_**.
" 06/11/84 by Lee Baldwin: Renamed bad_file_cr_blkg_fctr to
"	    bad_file_cr_blocking_factor.
" 08/27/84 by Matthew Pierret: Added fm_xring_brackets_mismatch.
" 10/24/84 by Lee A. Newcomb:  Added $dm_shutdown_not_sched.
" 11/27/84 by Matthew Pierret:  Added fm_bad_postcommit_operation,
"	    fm_bad_undo_operation, fm_too_many_openings.
" 12/04/84 by Stanford S. Cox: Added open_table_damaged.
" 12/05/84 by Lee A. Newcomb:  Removed obs. bj_bad_undo_info.
" 12/07/84 by Lindsey Spratt: Added $delete_pending_transaction, and 
"	    no_delete_dir_transaction.
" 01/29/85 by Steve Herbst: Added file_was_deleted.
" 02/26/85 by Lee A. Newcomb:  Added $too_many_bootload_dirs.  Removed the
"	    obsolete:  aim_auth_not_found, aim_invalid_control_seg,
"	    bj_already_adopting, bj_bad_buffer_address,
"	    bj_no_more_previous_ci, bj_no_previous_ci, bj_no_pst,
"	    bj_no_txn, bj_pst_full, bj_pst_mod_list_full,
"	    dms_already_in_operation, dms_unknown_action,
"	    file_path_too_long, fm_no_current_txn, invalid_dms_call, and
"	    no_journal_seg.
" 02/28/85 by Steve Herbst:  Added $fm_cant_remove_name, returned by
"	    fm_attribute_fref_$chname_file when a user tries to remove
"	    a name from a DM file.
" 03/13/85 by R. Michael Tague:  Added $fm_word_increment_error, 
"	    $invalid_increment_offset, $invalid_increment_words,
"	    $long_increment_length, and $fm_bad_inc_info_ver.
" 03/21/85 by R. Michael Tague:  Added $file_must_be_protected.
" 
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

" HISTORY COMMENTS:
"  1) change(86-12-21,Hergert), approve(87-04-01,MCR7632),
"     audit(87-01-30,Dupuis), install(87-04-02,MR12.1-1020):
"     Added $incr_array_not_found.
"                                                      END HISTORY COMMENTS


	include 	et_macros
	et 	dm_error_


ec area_overflow,areaovfl,
          (The requested allocation caused the area to overflow.)

ec bad_element_length,badelen,
          (The specified element length is negative.)

ec bad_file_atrs_length,bdfiatlg,
	(The value of the file attributes length field differs from the actual length of the file attributes.)

ec bad_file_atrs_uid,bdfiatud,
	(The unique identifier in the file attributes is incorrect.)

ec bad_file_atrs_ver,bdfiatvr,
	(The version of the file attributes is incorrect.)

ec bad_file_cr_blocking_factor,bdficrbf,
	(The file creation information blocking factor is invalid.)

ec bad_file_cr_ci_size,bdficrcz,
	(The file creation information control interval size is not supported.)

ec bad_file_cr_info_ver,bdficriv,
	(The file creation information version is incorrect.)

ec bad_file_oid,badfioid,
	(The specified file opening identifier is invalid.)

ec bad_first_key_idx,badfkeyx,
          (The first key index is invalid.)

ec bad_last_key_idx,badlkeyx,
          (The last key index is invalid.)

ec bad_leaf_node,badlnode,
          (The node is not a leaf node as expected.)

ec bad_parent_thread,badpar,
	(The parent-child pointers between two nodes do not agree.)

ec bad_rel_cursor_pos,badrcpos,
          (The relation cursor does not have a defined current position.)

ec bad_specification_type,badspect,
          (The supplied specification type is not supported by this operation.)

ec bad_vector_type,badvect,
	(The supplied vector type is not supported by this operation.)

ec beginning_of_collection,begcoll,
          (An attempt was made to access before the beginning of the collection.)

ec bj_bad_ci_no,bjbadci,
	(An incorrect control interval number has been encountered.)

ec bj_bad_buffer_uid,bjbdbfud,
	(The UIDs of a before journal buffer and the corresponding before journal differ.)

ec bj_bad_continuation_flag,bjbdcnf,
	(Bad continuation flag.)

ec bj_bad_first_txn_record_type,bjbd1rct,
	(The specified record is invalid as the first record in a before journal transaction chain.)

ec bj_bad_header,bjbdhdr,
	(The format of the before journal header is invalid.)

ec bj_bad_ppt_version,pptvbad,
	(The format of the before journal PPT is invalid.)

ec bj_bad_ppte_version,pptevbad,
	(The format of the before journal PPT entry is invalid.)

ec bj_bad_pst_version,pstvbad,
	(Unrecognized before journal PST format encountered.)

ec bj_bad_pste_idx,bjbdptix,
	(A before journal PST entry index is invalid.)

ec bj_bad_pste_ptr,bjbdptpt,
	(A before journal PST entry pointer is invalid.)

ec bj_bad_pste_version,pstevbad,
	(Unrecognized before journal PST entry format encountered.)

ec bj_bad_rec_count,bjbdrcc,
	(The number of records written does not agree with number of records read.)

ec bj_bad_rec_id,bjbdrid,
	(Bad record ID.)

ec bj_bad_slot_no,bjbdstno,
	(The slot number requested is greater than the number of slots in the control interval.)

ec bj_bad_tid,bjbdtid,
	(The before journal transaction table entry does not correspond to the referenced transaction.)

ec bj_bad_txt_version,bjbdtxtv,
	(The before journal TXT version is not implemented.)

ec bj_cant_abort,bjcantab,
	(Writing an abort mark for this transaction is not allowed.)

ec bj_cant_commit,bjcantcm,
	(Writing a commit mark for this transaction is not allowed.)

ec bj_first_txn_rec_not_found,bfno1trc,
	(A before journal transaction chain appears before the beginning of the chain.)

ec bj_illegal_size,bjilglsz,
	(A before journal must have at least three control intervals.)

ec bj_incomplete_rollback,bjincrb,
	(Not all of the before images could be rolled back.)

ec bj_inconsistent_ci,bjincsci,
	(A before journal control interval has an internal inconsistency.)

ec bj_invalid_name,bjinvnm,
	(The supplied name is not acceptable for a before journal.)

ec bj_journal_full,bjfull,
	(The before journal is full.)

ec bj_journal_in_use,bjinuse,
	(The requested operation could not be completed because the journal is being used.)

ec bj_journal_not_opened,bjntopen,
	(The referenced before journal is not opened.)

ec bj_journal_not_registered,bjntregs,
	(The before journal is not in the before journal check-in table.)

ec bj_logic_err,bjlogerr,
	(A logical inconsistency has been detected in the before journal manager.)

ec bj_needed_for_recovery,bjndrcr,
	(A before journal contains transactions from a previous bootload.)

ec bj_neg_txns_in_unfinished_rec,bjnegtxn,
	(A before journal record indicates a negative number of transactions are active in the journal.)

ec bj_no_next_used_ci,bjnonuci,
	(A before journal has no used control intervals after the current one.)

ec bj_no_previous_used_ci,bjnopuci,
	(A before journal has no used control interval previous to the current one.)

ec bj_not_adopting,bjnoadpt,
	(The before journal manager has not adopted a transaction to be abandoned.)

ec bj_not_all_opened_after_crash,bjntaopn,
	(Some before journals could not be opened for crash recovery.)

ec bj_not_my_txn,bjntmtxn,
	(This process is not set up to work with the transaction.)

ec bj_ppt_full,bjpptful,
	(The before journal PPT is full.)

ec bj_pst_cit_full,bjctful,
	(The before journal check-in table is full.)

ec bj_pst_not_enough_buffers,pstnobuf,
	(There are not enough before journal PST buffers.)

ec bj_rec_process_id_mismatch,bjbdrpid,
	(Two before journal records in a transaction chain contain different process IDs.)

ec bj_rec_txn_id_mismatch,bjbdrtid,
	(Two records in a before journal transaction chain contain different transaction identifiers.)

ec bj_recursive_invoc,bjrecurs,
	(There has been a recursive invocation of the before journal manager.)

ec bj_rollback_bad_cp_no,bjrbbdcp,
	(An invalid checkpoint number has been found.)

ec bj_this_not_adopted,bjntadpt,
	(The before journal manager did not adopt the specified transaction.)

ec bj_too_few_records,bjfewrec,
	(Fewer records were found than expected in a backwards walk of a before journal.)

ec bj_too_few_unfinished_txns,bjfewtxn,
	(Fewer active transactions were found in a before journal than expected from the last record written.)

ec bj_too_many_unfinished_txns,bjmantxn,
	(More active transactions were found in a before journal than expected from the last record written.)

ec bj_txn_aborted,bjtxnab,
	(The transaction has been aborted.)

ec bj_txn_committed,bjtxncom,
	(The transaction has been committed.)

ec bj_uids_dont_agree,bjudnagr,
	(The before journal UID in the hardcore journal entry differs from the UID in the before journal PST entry.)

ec bj_uids_dont_match,bjudnmtc,
	(The specified before journal UID differs from the UID in the before journal PST entry.)

ec bj_unexpected_aborted_mark,bjunexab,
	(A before journal transaction chain has an abort mark before the last record.)

ec bj_unexpected_committed_mark,bjunxcom,
	(A before journal transaction chain has a commit mark before the last record.)

ec bj_unexpected_eot_mark,bjunxeot,
	(A before journal transaction chain has an end-of-transaction mark before the last record in the transaction chain.)

ec bj_unknown_record_type,bjbdrect,
	(The type of the before journal record is not valid.)

ec bj_wrong_numb_txn_records,bjwnotxn,
	(The number of records for a transaction in a before journal is stored incorrectly in a record.)

ec bj_wrong_prev_rec_id,bjbdprid,
	(The before journal transaction record has a stored previous record ID which differs from the actual previous record.)

ec bj_zero_txns_in_unfinished_rec,bj0txnrc,
	(A non-end-of-transaction before journal record indicates no active transactions.)

ec cant_buffer_ci_continuations,nobufcn,
          (The control interval is not eligible for buffered access.)

ec ci_0_invalid_free,ci0free,
          (Control interval zero cannot be freed.)

ec ci_already_allocated,cialloc,
	(The control interval is already allocated.)

ec ci_already_free,cifree,
	(The control interval is already free.)

ec ci_bad_hdr_arg_ver,cibdhav,
	(The version of the control interval header is wrong.)

ec ci_bad_hdr_id_num,cibdhin,
	(The specified control interval has the wrong sequence number.)

ec ci_bad_hdr_size_code,cibdhsz,
	(The specified control interval has an invalid size code.)

ec ci_bad_hdr_uid,cibdhuid,
	(The specified control interval has an incorrect unique identifier.)

ec ci_bad_stamp_ver,cibdsv,
	(The specified control interval is the wrong version or is damaged.)

ec ci_buffer_too_small,shortbuf,
          (The supplied buffer is not large enough to hold a control interval.)

ec ci_not_allocated,cinalloc,
          (The control interval has not been allocated.)

ec ci_not_in_collection,outofcol,
          (The requested control interval is not contained in the given collection.)

ec ci_num_oob,cinoob,
	(The specified control interval number is out of bounds.)

ec ci_num_parts_neg,cinpneg,
	(A negative number of control interval parts was specified.)

ec ci_parts_oob,cipoob,
	(The specified control interval part goes beyond the addressable range.)

ec col_is_inconsistent,colisinc,
          (The collection is internally inconsistent.)

ec collection_not_found,nocol,
          (The specified collection was not found.)

ec collection_not_in_relation,nocolrel,
          (The specified index or record collection does not exist in the relation.)

ec delete_pending_transaction,delptxn,
          (The object will be deleted when the current transaction commits.)

ec dm_shutdown_not_sched,dmshdnns,
	(Unable to schedule requested DM shutdown.)

ec (element_not_found,no_element),noelem,
          (No element was found.)

ec end_of_collection,endcoll,
	(An attempt was made to access beyond the end of the collection.)

ec fast_lock_invalid_lock,flinvlk,
	(The fast lock double-word contains invalid data.)

ec fast_lock_invalid_reset,flinvrs,
	(The fast lock was locked to a dead or invalid process. It is now locked to this process.)

ec fast_lock_mylock,flmylock,
	(The fast lock is already locked to this process.)

ec fast_lock_no_free,flnofree,
	(There are no free blocks available for this fast lock operation.)

ec fast_lock_not_cleared,flnoclr,
	(The fast lock has not been initialized or has been modified.)

ec fast_lock_not_locked,flnolock,
	(The fast lock is not locked to this process.)

ec fast_lock_timeout,fltmot,
	(The fast lock could not be obtained in the time specified.)

ec file_already_exists,fileis,
	(The data management file already exists.)

ec file_already_open,fileopen,
	(The data management file is already open.)

ec file_cr_info_mbz_nz,ficrimbz,
	(A file creation information item that must be zero is not.)

ec file_doesnt_exist,fileisnt,
	(The data management file does not exist.)

ec file_duplication,filedup,
	(There is more than one data management file with the same unique identifier.)

ec file_in_use,filinuse,
          (The operation can't be done because the data management file is in use.)

ec file_must_be_protected,flprot,
	(The operation can't be done because the data management file is not a protected file.)

ec file_not_dm_type,flnotdm,
	(The file does not look like a data management file.)

ec file_uid_arg_null,fiudnull,
	(The specified data management file unique identifier argument is null.)

ec file_uid_not_found,fiudnofd,
	(The specified data management file unique identifier is not in the uid-pathname table.)

ec file_was_deleted,fiwsdltd,
	(The file has been deleted.)

ec fm_bad_inc_info_ver,badiiv,
	(The data management fm_increment_info structure version is bad.)

ec fm_bad_postcommit_operation,badpcop,
          (A data management file postcommit handler contains an unsupported operation.)

ec fm_bad_proc_txn_tbl_ver,fmbdpttv,
	(The data management file perprocess transaction table version is incorrect.)

ec fm_bad_sys_pn_tbl_ver,fmbdsptv,
	(The version of the data management file system uid-pathname table is incorrect.)

ec fm_bad_undo_op,badrbop,
          (A data management file rollback handler contains an unsupported operation.)

ec fm_cant_free_ci_0,fmctfrc0,
	(Control interval zero of a data management file can not be freed.)

ec fm_cant_remove_name,fmctrmnm,
	(Names cannot be removed from DM files.)

ec fm_first_ci_neg,fmfrcing,
	(The argument specifying the first in a range of control intervals was negative.)

ec fm_num_ci_neg,fmncineg,
	(The specified the number of control intervals in a range was negative.)

ec fm_old_txn_not_flushed,fmotxnfl,
	(The modified control intervals from the last transaction were not flushed.)

ec fm_old_uidpn_ptr_null,fmoupnpn,
	(The pointer to the old uid-pathname table is not set.)

ec fm_proc_tbl_full,fmptfull,
	(This process can not open another data management file because its table is full.)

ec fm_sys_pn_tbl_full,fmsptful,
	(The data management-file system uid-pathname table is full.)

ec fm_sys_pne_clobbered,fmspnecb,
	(An entry in the data management file system uid-pathname table looks damaged.)

ec fm_too_many_openings,fmopnoob,
          (A data management file has been opened the maximum number of times for this process.)

ec fm_uid_fnd_wrong_file,fmuidfwf,
	(An attempt to open a data management file by its UID opened the wrong file.)

ec fm_word_increment_error,fmwrdinc,
	(Unable to increment a data management file word value after several attempts.)

ec fm_xring_brackets_mismatch,fmbadxrb,
          (The data management file's ring brackets do not match their encoded form.)

ec incr_array_not_found,incanfnd,
          (The key count array containing the increments array could not be found at postcommit time.)

ec index_not_in_relation,idxnirel,
	(The specified index is not in the relation.)

ec invalid_alignment,invalign,
	(The specified alignment is inconsistent with the specified data type.)

ec invalid_current_txn,invctxn,
	(The information about the current transaction for this process is invalid.)

ec invalid_cursor_position,invcpos,
	(The cursor does not have a valid current position.)

ec invalid_element_id,inveid,
	(The requested element ID does not correspond to an existing element.)

ec invalid_increment_offset,invioff,
	(The offset to the first word to be incremented cannot be less than 0.)

ec invalid_increment_words,inviwrds,
	(There number of words to be incremented must be at least one.)

ec invalid_mode,invmode,
	(The specified mode is invalid.)

ec invalid_scope,invscope,
	(The specified scope setting is invalid.)

ec invalid_specification_field,invspfd,
	(A field specified in the search specification does not exist in the relation.)

ec key_duplication,keydup,
	(A key was duplicated.)

ec key_not_found,nokey,
	(No key was found.)

ec keys_out_of_order,keyooo,
	(Keys in the index are not in the correct order.)

ec lock_deadlock,lkdead,
	(Waiting for the lock would cause a deadlock.)

ec lock_invalid_mode,lkinvmd,
	(The lock mode requested is not valid.)

ec lock_invalid_uid,lkinvuid,
	(The unique identifier supplied is not valid.)

ec lock_not_found,lkntfnd,
	(The lock is not locked.)

ec lock_process_active,lkpract,
	(The specified process is an active process.)

ec lock_table_overflow,lktbov,
	(A lock table overflowed.)

ec lock_timeout,lktmot,
	(The lock could not be obtained in the time specified.)

ec long_element,lgelem,
	(More space is needed in the specified control interval to store the element.)

ec long_increment_length,lginclen,
	(More words being incremented than exist in file element.)

ec long_return_element,lgrelem,
          (The element is too long to fit in the supplied output buffer.)

ec misformatted_ci,badci,
	(The requested control interval is not formatted correctly.)

ec no_begins,nobegins,
	(No transactions can be begun.)

ec no_current_transaction,nocurtxn,
	(There is no current transaction.)

ec no_datum,nodatum,
          (No datum was found.)

ec no_delete_dir_transaction,noddtxn,
          (The directory contains objects which cannot be deleted until the current transaction commits.)

ec no_header_record,nohdrrec,
          (The collection does not have a caller-defined header record.)

ec no_opening,noopen,
	(The specified opening does not exist.)

ec no_output_buffer,nobuff,
	(No output buffer was supplied to return the requested data.)

ec no_suspended_transaction,nosustxn,
	(There is no suspended transaction.)

ec no_user_dm,nouserdm,
	(Data Management is not initialized in this process.)

ec non_empty_relation,nemtrel,
	(The index can not be created in a nonempty relation.)

ec not_daemon,ntdmn,
	(This procedure can only be called by Data_Management.Daemon.)

ec not_own_transaction,ntowntxn,
	(The transaction does not belong to this process.)

ec open_table_damaged,optbdmgd,
	(The data management open table appears damaged.)

ec partial_recovery,partrcvr,
	(One or more transactions could not be recovered after a crash.)

ec per_process_area_overflow,pparov,
	(The per-process area has overflowed.)

ec per_system_not_init,psysnoti,
	(An error was encountered during per-system initialization.)

ec process_not_found,prcntfnd,
	(The specified process is not in the TDT.)

ec programming_error,progerr,
          (An inconsistency has occurred due to an internal programming error.)

ec record_not_found,norec,
          (The record was not found.)

ec rel_cursor_spec_mismatch,badrlscp,
          (The current and supplied specifications do not agree.)

ec relation_not_open,relnopen,
          (The specified relation is not open.)

ec record_quota_overflow,rqover,
	(A record quota overflow occurred while expanding a lock segment.)

ec short_buffer,shrtbuff,
	(The buffer is too small too hold the requested data.)

ec system_config_file_checksum_err,scfcksum,
	(The checksum recorded in the DM configuration file does not agree with the generated checksum.)

ec system_not_initialized,sysninit,
	(The Data Management System is not available.)

ec tdt_entry_in_use,tdtinuse,
	(The TDT entry is already in use.)

ec tdt_entry_not_freed,tdtnfree,
	(The TDT entry could not be freed.)

ec tdt_full,tdtfull,
	(The TDT is full.)

ec too_many_bootload_dirs,tmbootdr,
	(More than one file system object matches the DM bootload dir starname.)

ec transaction_in_progress,txninprg,
	(A transaction is currently in progress.)

ec transaction_not_abandoned,txnnabnd,
	(The transaction has not been abandoned.)

ec transaction_not_current,txnncur,
	(The specified transaction is not the current transaction.)

ec transaction_not_found,notxn,
	(The specified transaction is not defined.)

ec transaction_suspended,txnsuspd,
	(The specified transaction is currently suspended.)

ec transactions_out_of_sequence,txnoosq,
	(Transactions are out of sequence.)

ec (tuple_not_found,no_tuple),notup,
	(No tuples were found.)

ec (tuple_not_found_id,no_tuple_id),notupid,
	(No tuple was found with the given tuple identifier.)

ec unexpected_search_case,unxsrhcs,
	(An unexpected case has occurred as the result of searching an index.)

ec unfinished_abort,unfinab,
	(A transaction abort attempt has been interrupted.)

ec unfinished_commit,unfincom,
	(A transaction commit attempt has been interrupted.)

ec unfinished_rollback,unfrolbk,
	(A transaction rollback attempt has been interrupted.)

ec unimplemented_ci_version,invciv,
          (The supplied control interval version is not implemented.)

ec unimplemented_cism,invcism,
	(The collection does not support the requested control interval storage method.)

ec unimplemented_data_type,invdt,
	(The supplied data type is not supported for the requested operation.)

ec unimplemented_entry,invet,
	(This entry is not yet implemented.)

ec unimplemented_esm,invesm,
          (The collection does not support the requested element storage method.)

ec unimplemented_spec_version,invspecv,
	(The supplied specification version is not implemented.)

ec unsup_search_spec_head_type,invsphd,
	(The supplied specification type is not implemented.)

ec unsup_search_spec_range_type,invsprg,
	(The supplied specification range type is not implemented.)

ec unsupported_spec_operator,invspop,
	(The supplied specification operator is not implemented.)

ec valid_process,validprc,
	(The process is currently in operation.)

ec wrong_cursor_type,invcurst,
          (The supplied cursor type is not supported by this operation.)


	end




		    dm_fast_lock_meters.pl1         05/06/86  1320.6rew 05/06/86  1313.4      100143



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



/****^  HISTORY COMMENTS:
  1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Made to convert seconds into minutes instead of hours.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

This command displays metering information about Data Management fast locking.
*/

/* HISTORY:

Written by Stanford S. Cox, 03/28/85.
Modified:
05/12/85 by S. Cox: Moved metering delta calculations into ioa_ call.
*/
/* format: style2,^inddcls,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3,idind32 */
%page;
dm_fast_lock_meters:
   proc ();

/* START OF DECLARATIONS */
/* Automatic */

dcl     accept_control_argument	bit (1) aligned init ("0"b);
dcl     arg_idx			fixed bin;
dcl     arg_len			fixed bin (21);
dcl     arg_list_ptr		ptr init (null);
dcl     arg_ptr			ptr;
dcl     code			fixed bin (35);
dcl     control_argument_idx		fixed bin;
dcl     current_time		fixed bin (71);
dcl     force_interpretation_as_argument
				bit (1) aligned init (NO);
dcl     is_active_function		bit (1) aligned init (NO);
dcl     1 local_lock_list_meters	aligned like lock_list_meters;
dcl     number_of_args		fixed bin;
dcl     report_current_meters		bit (1) aligned init (YES);
dcl     reset_saved_meters		bit (1) aligned init (NO);
dcl     sci_ptr			ptr init (null);
dcl     this_is_a_standalone_invocation bit (1) aligned init (YES);

/* Based */

dcl     arg			char (arg_len) based (arg_ptr);
dcl     1 saved_lock_list_meters	aligned like lock_list_meters based (saved_lock_list_meters_ptr);
dcl     system_area			area based (get_system_free_area_ ());

/* Builtin */

dcl     (addr, clock, divide, hbound, index, mod, null, substr, unspec)
				builtin;
dcl     (cleanup, dm_not_available_)	condition;

/* Constant */

dcl     (
        YES			init ("1"b),
        NO			init ("0"b)
        )				bit (1) aligned internal static options (constant);
dcl     myname			init ("dm_fast_lock_meters") char (19) internal static options (constant);

dcl     (
        MICROSECONDS_PER_SECOND	init (1e6),
        MINUTES_PER_HOUR		init (60),
        SECONDS_PER_HOUR		init (3600),
        SECONDS_PER_MINUTE		init (60)
        )				fixed bin (35) internal static options (constant);

dcl     ARGUMENT_TYPE		(4) internal static options (constant) char (64) varying init ("", "", "", "");
dcl     CONTROL_ARGUMENT		(4) internal static options (constant) char (64) varying
				init ("-reset", "-rs", "-report_reset", "-rr");

/* Static */

dcl     (
        saved_lock_list_meters_ptr	ptr init (null ()),
        saved_time			fixed bin (71)
        )				internal static;

/* Entry */

dcl     cu_$arg_list_ptr		entry (ptr);
dcl     dm_misc_util_$get_initialization_time
				entry () returns (fixed bin (71));
dcl     get_system_free_area_		entry () returns (ptr);
dcl     ioa_			entry () options (variable);
dcl     lock_manager_$copy_fast_data	entry (ptr, ptr, fixed bin (35));
dcl     ssu_$abort_line		entry () options (variable);
dcl     ssu_$arg_ptr		entry (ptr, fixed bin, ptr, fixed bin (21));
dcl     ssu_$arg_count		entry (ptr, fixed bin);
dcl     ssu_$destroy_invocation	entry (ptr);
dcl     ssu_$standalone_invocation	entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
dcl     sub_err_			entry () options (variable);

/* External */

dcl     (
        dm_error_$system_not_initialized,
        error_table_$action_not_performed,
        error_table_$bad_arg,
        error_table_$badopt,
        error_table_$noarg,
        error_table_$unimplemented_version
        )				fixed bin (35) external;

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on dm_not_available_ call ERROR_RETURN (dm_error_$system_not_initialized, "");
      on cleanup call CLEANUP ();

      call ssu_$arg_count (sci_ptr, number_of_args);

      accept_control_argument = YES;
      control_argument_idx = -1;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to number_of_args;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES
         then call PROCESS_ARGUMENT (arg, control_argument_idx, accept_control_argument);
         else if accept_control_argument = YES
         then call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx, accept_control_argument,
	         force_interpretation_as_argument);
         else call REPORT_MISSING_ARGUMENT (control_argument_idx);
      end ARG_PROCESSING_LOOP;

      if control_argument_idx >= 0 & accept_control_argument = NO
      then call REPORT_MISSING_ARGUMENT (control_argument_idx);

      call lock_manager_$copy_fast_data (null (), addr (local_lock_list_meters), code);
      if code = error_table_$action_not_performed then call ERROR_RETURN (code, "Fast locks are not being metered");
      else if code ^= 0 then call ERROR_RETURN (code, "Getting temporary segment to hold lock data");
      call CHECK_VERSION (LOCK_LIST_METERS_VERSION_1, local_lock_list_meters.version, "lock_list_meters");

      current_time = clock ();

      if saved_lock_list_meters_ptr = null () then do;
         allocate saved_lock_list_meters in (system_area);
         unspec (saved_lock_list_meters) = "0"b;
         saved_time = dm_misc_util_$get_initialization_time ();
      end;

      if report_current_meters then do;
         call DISPLAY_TOTAL_METERING_TIME (current_time - saved_time);
         call ioa_ (
	    "Fast lock or waiter block:^/thread in calls / steps^5xthread out calls / steps^/^9x^6d^2x^6d^15x^6d^2x^6d",
	    local_lock_list_meters.thrdin_calls - saved_lock_list_meters.thrdin_calls,
	    local_lock_list_meters.thrdin_steps - saved_lock_list_meters.thrdin_steps,
	    local_lock_list_meters.thrdout_calls - saved_lock_list_meters.thrdout_calls,
	    local_lock_list_meters.thrdout_steps - saved_lock_list_meters.thrdout_steps);
      end;

      if reset_saved_meters then do;
         saved_lock_list_meters = local_lock_list_meters;
         saved_time = current_time;
      end;

      call FINISH;

MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_code, er_message);


dcl     er_code			fixed bin (35) parameter;
dcl     er_message			char (*) parameter;

      call ssu_$abort_line (sci_ptr, er_code, er_message);
   end;

ABORT_ENTRY:
   procedure ();
      call CLEANUP ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;



CLEANUP:
   procedure ();
      call FINISH ();
   end CLEANUP;

FINISH:
   proc ();
      call ssu_$destroy_invocation (sci_ptr);
   end FINISH;

DISPLAY_TOTAL_METERING_TIME:
   proc (dmt_p_duration_in_microseconds);

dcl     dmt_p_duration_in_microseconds	fixed bin (71);
dcl     dmt_duration_in_seconds	fixed bin (71);
dcl     dmt_hours			fixed bin (71);
dcl     dmt_minutes			fixed bin (71);
dcl     dmt_seconds			fixed bin (71);

      dmt_duration_in_seconds = divide (dmt_p_duration_in_microseconds, MICROSECONDS_PER_SECOND, 71, 0);
      dmt_seconds = mod (dmt_duration_in_seconds, SECONDS_PER_MINUTE);
      dmt_minutes = mod (divide (dmt_duration_in_seconds, SECONDS_PER_MINUTE, 71, 0), MINUTES_PER_HOUR);
      dmt_hours = divide (dmt_duration_in_seconds, SECONDS_PER_HOUR, 71, 0);

      call ioa_ ("^/Total metering time:^2x^i:^[0^]^i:^[0^]^i^/", dmt_hours, (dmt_minutes < 10), dmt_minutes,
	 (dmt_seconds < 10), dmt_seconds);

   end DISPLAY_TOTAL_METERING_TIME;

CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl     cv_p_expected_version		char (8) aligned parameter;
dcl     cv_p_received_version		char (8) aligned parameter;
dcl     cv_p_structure_name		char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/Expected version ^a of the ^a structure." || "^/Received version ^a instead.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;

PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

dcl     pa_p_arg			char (*) parm;
dcl     pa_p_control_argument_idx	fixed bin parm;
dcl     pa_p_accept_control_argument	bit (1) aligned parm;

dcl     pa_code			fixed bin (35);

      pa_code = 0;

      goto ARGUMENT (pa_p_control_argument_idx);
ARGUMENT (-1):
      call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The argument ""^a"" is out of place.", arg);
      return;
   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument, pca_p_force_interpretation_as_argument);


dcl     pca_p_arg			char (*) parm;
dcl     pca_p_control_argument_idx	fixed bin parm;
dcl     pca_p_accept_control_argument	bit (1) aligned parm;
dcl     pca_p_force_interpretation_as_argument
				bit (1) aligned parm;

      pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
      pca_p_accept_control_argument = YES;
      pca_p_force_interpretation_as_argument = NO;

      go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
      call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* -reset */
CONTROL_ARGUMENT (2):				/* -rs */
      reset_saved_meters = YES;
      report_current_meters = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (3):				/* -report_reset */
CONTROL_ARGUMENT (4):				/* -rr */
      reset_saved_meters = YES;
      report_current_meters = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


   end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

dcl     cai_p_arg			char (*);
dcl     cai_control_argument_idx	fixed bin;

      do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	 while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
      end;
      if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
      then return (-1);
      else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;

REPORT_MISSING_ARGUMENT:
   proc (rma_p_control_argument_idx);
dcl     rma_p_control_argument_idx	fixed bin parm;

      call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	 CONTROL_ARGUMENT (rma_p_control_argument_idx),
	 (index ("aeiouh", substr (ARGUMENT_TYPE (rma_p_control_argument_idx), 1, 1)) > 0),
	 ARGUMENT_TYPE (rma_p_control_argument_idx));
   end REPORT_MISSING_ARGUMENT;
%page;
%include dm_lock_list_strucs;
%page;
%include sub_err_flags;
   end dm_fast_lock_meters;




		    dm_fast_lock_status.pl1         07/13/88  1122.6r w 07/13/88  0937.9      176472



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

/* DESCRIPTION:

Displays the status of all of the fast locks currently being held or awaited on by processes using DM.
*/

/* HISTORY:

Written by S. Cox, 03/20/85.
Modified:
05/17/85 by S. Cox: Changed to check for locks with no waiters.
*/


/****^  HISTORY COMMENTS:
  1) change(87-04-27,GDixon), approve(87-07-08,MCR7741),
     audit(87-07-08,Hartogs), install(87-08-04,MR12.1-1055):
     Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1
                                                   END HISTORY COMMENTS */


/* format: style2,^inddcls,ifthenstmt,ifthendo,^indnoniterdo,^inditerdo,ind3,idind32 */
%page;
dm_fast_lock_status:
dmflst:
   proc ();

/* START OF DECLARATIONS */
/* Automatic */

dcl     accept_control_argument	bit (1) aligned init ("0"b);
dcl     answer_table_idx		fixed bin;
dcl     at_least_one_lock		bit (1) init (NO);
dcl     arg_idx			fixed bin;
dcl     arg_len			fixed bin (21);
dcl     arg_list_ptr		ptr init (null);
dcl     arg_ptr			ptr;
dcl     code			fixed bin (35);
dcl     control_argument_idx		fixed bin;
dcl     display_all_locks		bit (1) init (YES);
dcl     display_header		bit (1) init (NO);
dcl     display_waiters		bit (1) init (YES);
dcl     end_of_chain		bit (1) init (NO);
dcl     display_line_ptr		ptr;
dcl     fast_lock_displayed		bit (1) init (NO);
dcl     first_waiter		bit (1);
dcl     force_interpretation_as_argument
				bit (1) aligned init (NO);
dcl     given_process_id		bit (1) init (NO);
dcl     given_user_id		bit (1) init (NO);
dcl     lock_list_index		fixed bin;
dcl     number_of_args		fixed bin;
dcl     person_id			char (22);
dcl     project_id			char (9);
dcl     process_id_fb		fixed bin (35);
dcl     process_id_list_ptr		ptr;
dcl     process_idx			fixed bin;
dcl     save_lock_list_block_ptr	ptr init (null);
dcl     sci_ptr			ptr init (null);
dcl     this_is_a_standalone_invocation bit (1) aligned init (YES);
dcl     user			char (34);
dcl     user_match			bit (1) init (NO);
dcl     work_area_ptr		ptr;

/* Based */

dcl     arg			char (arg_len) based (arg_ptr);
dcl     display_line		char (MAX_LINE_LENGTH) varying based (display_line_ptr);
dcl     1 process_id_list		based (process_id_list_ptr),
	2 count			fixed bin (17),
	2 id			(0 refer (process_id_list.count)) bit (36) aligned;
dcl     work_area			area based (work_area_ptr);

/* Builtin */

dcl     (cleanup, dm_not_available_)	condition;
dcl     (addr, addrel, after, before, hbound, index, ltrim, null, pointer, rel, reverse, size, substr, unspec)
				builtin;


/* Constant */

dcl     (
        YES			init ("1"b) bit (1),
        NO			init ("0"b) bit (1),
        WAIT			char (4) init ("WAIT"),
        ANSWER_TABLE		char (32) init ("answer_table"),
        ABSENTEE_USER_TABLE		char (32) init ("absentee_user_table"),
        DAEMON_USER_TABLE		char (32) init ("daemon_user_table"),
        SYSDIR			char (168) init (">system_control_1")
        )				internal static options (constant);

/****  pages/seg * words/page - area overhead - varying char overhead */
dcl     MAX_LINE_LENGTH		fixed bin (21) internal static options (constant) init (255 * 1024 - 36 - 1);

dcl     myname			init ("dm_fast_lock_status") char (19) internal static options (constant);

dcl     ARGUMENT_TYPE		(16) internal static options (constant) char (64) varying
				init ("", "", "", "", "", "", "process id holding a fast lock",
				"process id holding a fast lock", "", "", "user id holding a fast lock",
				"user id holding a fast lock", "", "", "", "");
dcl     CONTROL_ARGUMENT		(16) internal static options (constant) char (64) varying
				init ("-header", "-he", "-no_header", "-nhe", "-lock_waiters", "-lkw",
				"-process_id", "-pid", "-all", "-a", "-user", "-user", "-no_lock_waiters",
				"-nlkw", "-all_processes", "-ap");
      ;

/* Entry */

dcl     cu_$arg_list_ptr		entry (ptr);
dcl     cv_oct_check_		entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl     cv_userid_			entry (char (*)) returns (char (32));
dcl     get_userid_			entry (bit (36) aligned, char (*), char (*), fixed bin, fixed bin, fixed bin (35))
				;
dcl     initiate_file_		entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl     match_star_name_		entry (char (*), char (*), fixed bin (35));
dcl     (
        ioa_,
        ioa_$rsnnl
        )				entry () options (variable);
dcl     lock_manager_$copy_fast_data	entry (ptr, ptr, fixed bin (35));
dcl     ssu_$abort_line		entry () options (variable);
dcl     ssu_$arg_count		entry (ptr, fixed bin);
dcl     ssu_$arg_ptr		entry (ptr, fixed bin, ptr, fixed bin (21));
dcl     ssu_$destroy_invocation	entry (ptr);
dcl     ssu_$get_area		entry (ptr, ptr, char (*), ptr);
dcl     ssu_$get_temp_segment		entry (ptr, char (*), ptr);
dcl     ssu_$standalone_invocation	entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
dcl     sub_err_			entry () options (variable);

/* External */

dcl     (
        dm_error_$system_not_initialized,
        error_table_$badopt,
        error_table_$bad_arg,
        error_table_$noarg,
        error_table_$unimplemented_version
        )				fixed bin (35) external;

/* END OF DECLARATIONS */

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on cleanup call CLEANUP ();
      on dm_not_available_ call ERROR_RETURN (dm_error_$system_not_initialized, "");

      call ssu_$get_area (sci_ptr, null (), myname, work_area_ptr);
      call ssu_$get_temp_segment (sci_ptr, myname, fast_lock_data_ptr);
      call ssu_$get_temp_segment (sci_ptr, myname, process_id_list_ptr);

      process_id_list.count = 0;
      allocate display_line in (work_area);
      call lock_manager_$copy_fast_data (fast_lock_data_ptr, null (), code);
      if code ^= 0 then call ERROR_RETURN (code, "Getting temporary segment to hold lock data");
      call CHECK_VERSION (FAST_LOCK_DATA_VERSION_1, fast_lock_data.version, "fast_lock_data");

      call ssu_$arg_count (sci_ptr, number_of_args);

      accept_control_argument = YES;
      control_argument_idx = -1;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to number_of_args;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES
         then call PROCESS_ARGUMENT (arg, control_argument_idx, accept_control_argument);
         else if accept_control_argument = YES
         then call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx, accept_control_argument,
	         force_interpretation_as_argument);
         else call REPORT_MISSING_ARGUMENT (control_argument_idx);
      end ARG_PROCESSING_LOOP;

      if control_argument_idx >= 0 & accept_control_argument = NO
      then call REPORT_MISSING_ARGUMENT (control_argument_idx);
%skip;
      lock_list_head_ptr = addr (fast_lock_data.free_list_head);
      lock_list_block_ptr = addr (fast_lock_data.list);
      lock_list_block_words = size (fast_lock_wakeup_block);

      lock_list_index = 0;
COUNT_FREE_ENTRIES:
      do lock_list_block_ptr = addr (fast_lock_data.list)
	 repeat addrel (lock_list_block_ptr, size (lock_list_block))
	 while (lock_list_block_ptr ^= pointer (fast_lock_data_ptr, lock_list_head.firstp));
         lock_list_index = lock_list_index + 1;
      end COUNT_FREE_ENTRIES;

      if display_header
      then call ioa_$rsnnl ("Lock Data Offset: ^w^/Version: ^a^/Size: ^d^/"
	      || "Free List Head Offset: ^w^/Number Free Entries: ^d^/Number Allocated Entries: ^d^/", display_line,
	      (0), rel (fast_lock_data_ptr), fast_lock_data.version, fast_lock_data.size, lock_list_head.firstp,
	      lock_list_index + 1, (fast_lock_data.n_list_entries - lock_list_index - 1));

      lock_list_index = lock_list_index + 2;		/* skip to allocated block */
ALLOCATED_BLOCK_LOOP:
      do lock_list_block_ptr = addrel (pointer (fast_lock_data_ptr, lock_list_head.firstp), size (lock_list_block))
	 repeat addrel (lock_list_block_ptr, size (lock_list_block))
	 while (lock_list_index <= fast_lock_data.n_list_entries);
         fast_lock_block_ptr, fast_lock_wakeup_block_ptr = addr (lock_list_block.block_data);

         if fast_lock_wakeup_block.message ^= WAIT & fast_lock_block.uid ^= ""b
         then
PROCESS_ACTIVE_LOCK:
	  do;
	  call ioa_$rsnnl ("^[^a^/^;^s^]UID ^w Offset ^w", display_line, (0), display_header, display_line,
	       fast_lock_block.uid, fast_lock_block.offset);
	  display_header = NO;

	  save_lock_list_block_ptr = lock_list_block_ptr;
	  end_of_chain, user_match = NO;
	  first_waiter = YES;
FIND_LOCK_WAITERS:
	  do lock_list_block_ptr = pointer (fast_lock_data_ptr, fast_lock_block.list_head)
	       repeat pointer (fast_lock_data_ptr, lock_list_block.nextp)
	       while (^end_of_chain & fast_lock_block.list_head ^= ""b);
	     fast_lock_wakeup_block_ptr = addr (lock_list_block.block_data);
	     if ^user_match & given_process_id then do;	/* is this block's process one the user gave us? */
	        do process_idx = 1 to process_id_list.count
		   while (fast_lock_wakeup_block.processid ^= process_id_list.id (process_idx));
	        end;
	        if process_idx <= process_id_list.count then do;
		 user_match = YES;			/* found a match, need not check this fast lock again */
		 at_least_one_lock = YES;
	        end;
	     end;
	     else if display_all_locks then at_least_one_lock = YES;

	     call get_userid_ (fast_lock_wakeup_block.processid, person_id, project_id, (0), (0), code);
	     if display_waiters then do;
	        call ioa_$rsnnl ("^a^[^/Waiters for this lock:^]^/^3xProcess ID ^w ^[(^a.^a)^;^s^s^] Event Channel ^w",
		   display_line, (0), display_line, first_waiter, fast_lock_wakeup_block.processid, (code = 0),
		   person_id, project_id, fast_lock_wakeup_block.event_channel);
	        first_waiter = NO;
	     end;
	     if lock_list_block.nextp = ""b then end_of_chain = "1"b;
	  end FIND_LOCK_WAITERS;
	  lock_list_block_ptr = save_lock_list_block_ptr;
	  if user_match | display_all_locks then call ioa_ (display_line);
         end PROCESS_ACTIVE_LOCK;

         lock_list_index = lock_list_index + 1;
      end ALLOCATED_BLOCK_LOOP;

      if display_header then call ioa_ (display_line);	/* No fast locks and user wants to see header */
      if display_all_locks & ^at_least_one_lock then call ioa_ ("There are no processes waiting on fast locks.");
      else if ^at_least_one_lock & given_process_id then do;
         call get_userid_ (process_id_list.id (1), person_id, project_id, (0), (0), code);
         call ioa_ ("^/No fast locks waited on by specified process^[. Process ID" || " ^w ^[(^a.^a)^]^;^s^s^s^ses. ^a",
	    (process_id_list.count = 1), process_id_list.id (1), (code = 0), person_id, project_id, user);
      end;

      call FINISH ();

MAIN_RETURN:
      return;

ERROR_RETURN:
   proc (er_code, er_message);

dcl     er_code			fixed bin (35) parameter;
dcl     er_message			char (*) parameter;

      call ssu_$abort_line (sci_ptr, er_code, er_message);
   end;

ABORT_ENTRY:
   procedure ();
      call CLEANUP ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;

CLEANUP:
   procedure ();
      call FINISH ();
   end CLEANUP;

FINISH:
   proc ();
      call ssu_$destroy_invocation (sci_ptr);
   end FINISH;

CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

dcl     cv_p_expected_version		char (8) aligned parameter;
dcl     cv_p_received_version		char (8) aligned parameter;
dcl     cv_p_structure_name		char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/Expected version ^a of the ^a structure." || "^/Received version ^a instead.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;

GET_PROCESS_ID_FROM_USER_ID:
   proc (gp_p_user_id, gp_p_process_id_list_ptr);

dcl     gp_p_user_id		char (34) parameter;
dcl     gp_p_process_id_list_ptr	ptr;
dcl     1 gp_process_id_list		like process_id_list aligned based (gp_p_process_id_list_ptr);

      call GET_ANSWER_TABLES;

      do answer_table_idx = 1 to anstbl.current_size;
         utep = addr (anstbl.entry (answer_table_idx));
         if ute.active >= 4 then call MATCH_USER_TABLE_ENTRY (gp_p_user_id, gp_p_process_id_list_ptr);
      end;

      do answer_table_idx = 1 to autbl.current_size;
         utep = addr (autbl.entry (answer_table_idx));
         if ute.active >= 4 then call MATCH_USER_TABLE_ENTRY (gp_p_user_id, gp_p_process_id_list_ptr);
      end;

      do answer_table_idx = 1 to dutbl.current_size;
         utep = addr (dutbl.entry (answer_table_idx));
         if ute.active >= 4 then call MATCH_USER_TABLE_ENTRY (gp_p_user_id, gp_p_process_id_list_ptr);
      end;

      if gp_process_id_list.count = 0
      then call ERROR_RETURN (error_table_$bad_arg, "User not logged in. " || gp_p_user_id);

      return;

GET_ANSWER_TABLES:
   proc ();

dcl     gat_code			fixed bin (35);

      call initiate_file_ (SYSDIR, ANSWER_TABLE, R_ACCESS, ansp, (0), gat_code);
      if ansp = null () then call ERROR_RETURN (gat_code, ANSWER_TABLE);
      call initiate_file_ (SYSDIR, ABSENTEE_USER_TABLE, R_ACCESS, autp, (0), gat_code);
      if autp = null () then call ERROR_RETURN (gat_code, ABSENTEE_USER_TABLE);
      call initiate_file_ (SYSDIR, DAEMON_USER_TABLE, R_ACCESS, dutp, (0), gat_code);
      if dutp = null () then call ERROR_RETURN (gat_code, DAEMON_USER_TABLE);
   end;
%skip;
MATCH_USER_TABLE_ENTRY:
   proc (mu_p_user_id, mu_p_process_id_list_ptr);

dcl     mu_p_process_id_list_ptr	ptr parameter;
dcl     mu_p_user_id		char (34) parameter;
dcl     1 mu_process_id_list		like process_id_list aligned based (mu_p_process_id_list_ptr);
dcl     mu_code			fixed bin (35);

      call match_star_name_ ((ute.person), before (mu_p_user_id, "."), mu_code);
      if mu_code = 0 then call match_star_name_ ((ute.project), before (after (mu_p_user_id, "."), "."), mu_code);
      if mu_code = 0 then call match_star_name_ ((ute.tag), before (ltrim (reverse (mu_p_user_id)), "."), mu_code);
      if mu_code = 0 then do;
         mu_process_id_list.count = mu_process_id_list.count + 1;
         mu_process_id_list.id (mu_process_id_list.count) = ute.proc_id;
      end;

   end;
   end;
%page;
PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

dcl     pa_p_arg			char (*) parm;
dcl     pa_p_control_argument_idx	fixed bin parm;
dcl     pa_p_accept_control_argument	bit (1) aligned parm;

dcl     pa_code			fixed bin (35);

      pa_code = 0;

      goto ARGUMENT (pa_p_control_argument_idx);
ARGUMENT (-1):
      call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The argument ""^a"" is out of place.", arg);
      return;

ARGUMENT (7):					/* -process_id */
ARGUMENT (8):					/* -pid */
      control_argument_idx = -1;
      accept_control_argument = YES;
      process_id_fb = cv_oct_check_ (arg, code);
      process_id_list.count = 1;
      unspec (process_id_list.id (1)) = unspec (process_id_fb);
      if code ^= 0 then call ERROR_RETURN (code, arg);
      given_process_id = YES;
      display_all_locks = NO;
      return;

ARGUMENT (11):					/* -user */
ARGUMENT (12):					/* -user */
      control_argument_idx = -1;
      accept_control_argument = YES;
      user = cv_userid_ (arg);
      call GET_PROCESS_ID_FROM_USER_ID (user, process_id_list_ptr);
      given_process_id = YES;
      display_all_locks = NO;
      return;

   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument, pca_p_force_interpretation_as_argument);


dcl     pca_p_arg			char (*) parm;
dcl     pca_p_control_argument_idx	fixed bin parm;
dcl     pca_p_accept_control_argument	bit (1) aligned parm;
dcl     pca_p_force_interpretation_as_argument
				bit (1) aligned parm;

      pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
      pca_p_accept_control_argument = YES;
      pca_p_force_interpretation_as_argument = NO;

      go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
      call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* -header */
CONTROL_ARGUMENT (2):				/* -he */
      display_header = YES;
      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;

CONTROL_ARGUMENT (3):				/* -no_header */
CONTROL_ARGUMENT (4):				/* -nhe */
      display_header = NO;
      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;

CONTROL_ARGUMENT (5):				/* -lock_waiters */
CONTROL_ARGUMENT (6):				/* -lkw */
      display_waiters = YES;
      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (7):				/* -process_id */
CONTROL_ARGUMENT (8):				/* -pid */
      pca_p_accept_control_argument = NO;
      return;


CONTROL_ARGUMENT (9):				/* -all */
CONTROL_ARGUMENT (10):				/* -a */
      display_all_locks = YES;
      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (11):				/* -user */
CONTROL_ARGUMENT (12):				/* -user */
      pca_p_accept_control_argument = NO;
      return;


CONTROL_ARGUMENT (13):				/* -no_lock_waiters */
CONTROL_ARGUMENT (14):				/* -nlkw */
      display_waiters = NO;
      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (15):				/* -all_processes */
CONTROL_ARGUMENT (16):				/* -ap */
      display_all_locks = YES;
      given_process_id = NO;
      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


   end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

dcl     cai_p_arg			char (*);
dcl     cai_control_argument_idx	fixed bin;

      do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	 while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
      end;
      if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
      then return (-1);
      else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;

REPORT_MISSING_ARGUMENT:
   proc (rma_p_control_argument_idx);
dcl     rma_p_control_argument_idx	fixed bin parm;

      call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	 CONTROL_ARGUMENT (rma_p_control_argument_idx),
	 (index ("aeiouh", substr (ARGUMENT_TYPE (rma_p_control_argument_idx), 1, 1)) > 0),
	 ARGUMENT_TYPE (rma_p_control_argument_idx));
   end REPORT_MISSING_ARGUMENT;

%page; %include absentee_user_table;
%page; %include access_mode_values;
%page; %include answer_table;
%page; %include daemon_user_table;
%page; %include dm_fast_lock_strucs;
%page; %include dm_lock_list_strucs;
%page; %include sub_err_flags;
%page; %include user_attributes;
%page; %include user_table_entry;
%page; %include user_table_header;

   end dm_fast_lock_status;




		    dm_find_configuration_.pl1      01/04/85  0952.6re  01/03/85  1150.3       36423



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

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

dm_find_configuration_:
     proc () returns (ptr);				/* returns a dm_system_config_ptr */


/* DESCRIPTION:

	This program returns a pointer to the data management configuration
     file in the per-AIM directory.  There  are  several  important points:
     - the configuration file MUST exist,
     - no validation is performed on the file; the config is simply initiated
       and a pointer to the start of the file is returned.

	A terminate entry is provided for cleaning up the address space
     of a process finished with the configuration file.
*/

/* HISTORY:

Written by Lee A. Newcomb, 05/03/83.
Modified:
05/06/83 by Lee A. Newcomb:  Changed to just return ptr to file, nothing more.
05/09/83 by Lee A. Newcomb:  added calls to sub_err_ when non-zero codes
            returned from calls made.
11/22/84 by Lee A. Newcomb:  To use dm_misc_util_$get_aim_dir.
*/
%page;
/* START OF DECLARATIONS */

dcl						/* Parameters */
     p_dm_system_config_ptr	        ptr		/* only used in terminate entry */
			        parameter;

dcl  (						/* Automatics */
     aim_dir		        char (168),
     code			        fixed bin (35),
     dm_system_config_ptr	        ptr		/* used by main entry */
     )			        automatic;

dcl						/* Builtins & Conditions */
     null			        builtin,
     cleanup		        condition;

dcl  (						/* Constants */
     myname		        char (32) varying init ("dm_find_configuration_"),
     CONFIG_FILE		        char (32) init ("dm_configuration")
     )			        internal static options (constant);

dcl						/* Entries */
     dm_misc_util_$get_aim_dir        entry (char (*)),
     hcs_$initiate		        entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     sub_err_		        entry () options (variable),
     term_$seg_ptr		        entry (ptr, fixed bin (35));


/* END OF DECLARATIONS */
%page;
/* Initialize parameter, local status code, and establish cleanup handler */

	dm_system_config_ptr = null ();
	code = 0;					/* no problems yet */

	on cleanup
	     call CLEAN_UP ();

/* Find the per-AIM directory */

	call dm_misc_util_$get_aim_dir (aim_dir);
	if code ^= 0 then
	     call sub_err_ (code, myname, ACTION_CANT_RESTART, null (), 0,
		"Cannot find per-AIM directory to contain DM configuration file.");

/* Find the configuration file */

	call hcs_$initiate (aim_dir, CONFIG_FILE, "",
	     0, 0, dm_system_config_ptr, code);		/* no reserved segno */
	if dm_system_config_ptr = null () then do;
	     call CLEAN_UP ();
	     call sub_err_ (code, myname, ACTION_CANT_RESTART, null (), 0,
		"Cannot initiate DM configuration file ^a>^a.", aim_dir, CONFIG_FILE);
	end;

	return (dm_system_config_ptr);
%page;
/* This entry simply cleans up the process address space. */

terminate:
     entry (p_dm_system_config_ptr);

/* initialize local status code for testing */

	code = 0;

/* just call term_ to do the real work */

	call term_$seg_ptr (p_dm_system_config_ptr, code);
	if code ^= 0 then
	     call sub_err_ (code, myname, ACTION_CANT_RESTART, null (), 0,
		"Cannot terminate reference to configuration file, seg no ^p.", p_dm_system_config_ptr);

	p_dm_system_config_ptr = null ();

	return;
%page;
CLEAN_UP:
     proc ();

/* Currently, we need only terminate the reference to the config file */

	if dm_system_config_ptr ^= null () then		/* we have the file known */
	     if code = 0 then do;			/* and this program is the one that did it */
		call term_$seg_ptr (dm_system_config_ptr, (0) /* ignore code */);
		dm_system_config_ptr = null ();
	     end;

	return;

     end CLEAN_UP;
%page;
%include sub_err_flags;


     end dm_find_configuration_;




		    dm_gen_checksum_.alm            01/04/85  0952.6re  01/03/85  1150.3       18936



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	dm_gen_checksum_ - subroutine to calculate checksums for data
"	management tables using technique described in MPM Reference
"	Guide.
"
"
"	Usage:
"	     dcl  dm_gen_checksum_ entry (ptr, fixed bin (18), fixed bin (35));
"	     call dm_gen_checksum_ (table_ptr, n_words, checksum);
"
"	written March 1983 by M. Pandolf
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	dm_gen_checksum_
	entry	dm_gen_checksum_

	equ	offset,1		"x1 is an offset into the table
	equ	words_left,2	"x2 counts number of words still to
				"be summed
	equ	table_ptr,2	"parm_no of table_ptr
	equ	table_size,4	"parm_no of n_words
	equ	checksum,6	"parm_no of checksum
	equ	indics,6		"use last parm as storage for
				"indicators during calculations
	bool	ovfl_mask,004000	"mask for inhibiting overflow

dm_gen_checksum_:

	eppbp	ap|table_ptr,*	"get pointer to pointer to table
	eppbp	bp|0,*		"get pointer to table

	ldi	ovfl_mask,dl	"inhibit overflow fault
	sti	ap|indics,*	"save indicators
	lda	0,dl		"initialize A-reg to zero
	eax	offset 0		"offset into table initialized

	lxl	words_left ap|table_size,*
				"load x2 with word count
loop:	tze	done		"if x2 zero, then finish

	ldi	ap|indics,*	"restore indicators
	awca	bp|0,offset	"add with carry to checksum
	sti	ap|indics,*	"save indicators because they become
				"modified by eax
	alr	1		"rotate A-reg left
	eax	offset 1,offset	"and bump offset counter
	eax	words_left -1,words_left
				"decrement amount still to go
	tra	loop		"see if any more to do

done:	ldi	ap|indics,*	"restore indicators
	awca	0,dl		"add in carry, if any
	awca	0,dl		"pick up carry generated by
				"prev instruction
	sta	ap|checksum,*	"return arg

	short_return

	end




		    dm_hcs_fake_.alm                05/17/85  1650.9re  05/17/85  1328.5       14994



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

" DESCRIPTION: 

" Fake Data Management gate for user ring testing.  The programs transferred
" to are calls needed by general DM users, and are otherwise only available in
" the inner ring.  (See dm_hcs_.alm)

" HISTORY: 

" Written by J. Bongiovanni, 11/01/82.
" Modified: 
" 02/18/85 by S. Cox:  Added guaranteed_eligibility_(on off) for lock_manager_.
" 05/10/85 by R. Michael Tague:  Added get_max_held_per_journal,
"	    get_n_journals, get_journal_stamp, and validate_bj_uid.
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	dm_hcs_fake_

	macro	hgate
	entry	&1
&1:	tra	&2$&3
	&end

	hgate	allocate_journal,hc_dm_util_,allocate_journal_index,3,bad_dir_trap
	hgate	free_journal,hc_dm_util_,free_journal_index,2,bad_dir_trap
	hgate	get_max_held_per_journal,hc_dm_util_,get_max_held_per_journal,1,bad_dir_trap
	hgate	get_n_journals,hc_dm_util_,get_n_journals,1,bad_dir_trap

	hgate	get_journal_stamp,hc_dm_util_,get_journal_stamp,2,bad_dir_trap
	hgate	set_journal_stamp,hc_dm_util_,set_journal_stamp,3,bad_dir_trap
	hgate	validate_bj_uid,hc_dm_util_,validate_bj_uid,3,bad_dir_trap

	entry	set_force_write_limit
set_force_write_limit:
	stz	pr0|4,*
	short_return

	entry	guaranteed_eligibility_off
	entry	guaranteed_eligibility_on
guaranteed_eligibility_off: 
guaranteed_eligibility_on: 
	nop
	short_return		

	end




		    dm_hphcs_fake_.pl1              01/04/85  0952.6re  01/03/85  1150.3       11853



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

/* DESCRIPTION:

	dm_hphcs_fake_  is  a  version  of  dm_hphcs_ to avoid ring crossing
     problems  in a test Data Management system (DMS); another example of this
     is  dm_hcs_fake_.  Currently, there is only one entry, ips_wakeup, and it
     is  a  no-op (as opposed to trying to get to pxss_ from ring 4).  We also
     use the dm_hphcs_ refname in the proc stmt to emphasis this is a fake.

	This  is  written in PL/I for now and will have to be transferred to
     ALM if more entries are added that need a transfer vector mechanism.
*/

/* HISTORY:

Written by Lee A. Newcomb, 10/05/84.
Modified:
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */

dm_hphcs_$ips_wakeup:
   proc ();

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */
/* Based */
/* Builtin */
/* Constant */
/* Entry */
/* External */
/* END OF DECLARATIONS */


MAIN_RETURN:					/* no-op */
   return;


   end dm_hphcs_$ips_wakeup;




		    dm_init_from_hardcore_.pl1      05/17/85  1650.9re  05/17/85  1328.5       39357



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

/* DESCRIPTION:

    Program to initialize per-system variables from hardcore variables.

    For testing, this program creates a dummy (user-ring) dm_journal_seg_
    and initializes it. Testing is determined by the ring of execution.
*/
/* HISTORY:

Written by J. Bongiovanni, 11/15/82.
Modified:
08/06/83 by Lee A. Newcomb: removed obsolete code args from calls
	  to dm_per_system_ entries.
11/29/84 by Stanford S. Cox: MAIN: Renamed dm_=, Chg to use initiate_file_, 
	  removed segfault handler, added cleanup handler. ER & FINISH: Added.
12/06/84 by Stanford S. Cox: FINISH: Chg to terminate journal seg before
                             resetting validation level.
05/10/85 by R. Michael Tague:  Changed to use dm_hcs_$get_n_journals.
*/

/* format: style4,indattr,ifthenstmt,ifthen,^indcomtxt,idind33 */
%page;
dm_init_from_hardcore_:
     proc (p_code);

/*  Parameter  */

dcl  p_code		        fixed bin (35);	/* Standard return code */

/*  Automatic  */

dcl  journalx		        fixed bin;
dcl  pagex		        fixed bin;
dcl  save_level		        fixed bin;

/*  Static  */

dcl  END_OF_TIME		        fixed bin (71) int static options (constant) init (111111111111111111111111111111111111111111111111111111b);
dcl  JOURNAL_DIR		        char (4) int static options (constant) init (">sl1");
dcl  JOURNAL_SEG		        char (15) int static options (constant) init ("dm_journal_seg_");
dcl  JOURNAL_WAIT_EVENT	        bit (36) aligned int static options (constant) init ("666000000000"b3);
dcl  MAX_DM_PAGES		        fixed bin int static options (constant) init (2048);
dcl  PER_ASTE_POOL		        (0:3) fixed bin int static options (constant) init (1000, 500, 200, 50);

/*  Entry  */

dcl  cu_$level_get		        entry (fixed bin);
dcl  cu_$level_set		        entry (fixed bin);
dcl  dm_hcs_$get_n_journals	        entry () returns (fixed bin);
dcl  dm_per_system_$create	        entry (char (*), ptr);
dcl  get_ring_		        entry () returns (fixed bin (3));
dcl  initiate_file_		        entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  terminate_file_	        entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/*  External  */

dcl  dm_system_data_$bj_max_n_journals fixed bin external;
dcl  sys_info$data_management_ringno  fixed bin external;

/*  Builtin  */

dcl  addr			        builtin;
dcl  null			        builtin;
dcl  rel			        builtin;

/*  Condition  */

dcl  cleanup		        condition;
%page;
	p_code = 0;

	if get_ring_ () = sys_info$data_management_ringno then do; /* "Live" */
	     call cu_$level_get (save_level);
	     on cleanup call FINISH ();
	     call cu_$level_set (get_ring_ ());
	     call initiate_file_ (JOURNAL_DIR, JOURNAL_SEG, R_ACCESS, dm_journal_segp, (0), p_code);
	     call cu_$level_set (save_level);
	     revert cleanup;
	     if dm_journal_segp = null () then call ERROR_RETURN;
	     p_code = 0;
	     dm_system_data_$bj_max_n_journals = dm_hcs_$get_n_journals ();
	     call FINISH ();
	end;

	else do;					/* "Test" */

	     call dm_per_system_$create (JOURNAL_SEG, dm_journal_segp);
	     dm_journal.n_journals = dm_system_data_$bj_max_n_journals;
	     dm_journal.max_held_pages_mem = MAX_DM_PAGES;
	     dm_journal.per_aste_pool (*).threshold = PER_ASTE_POOL (*);
	     dm_journal.free_list_relp = rel (addr (dm_journal.page_entry));
	     dm_journal.wait_event = JOURNAL_WAIT_EVENT;
	     do journalx = 1 to dm_journal.n_journals;
		dm_journal.per_journal (journalx).time_stamp = END_OF_TIME;
	     end;
	     do pagex = 1 to dm_journal.max_held_pages_mem - 1;
		dm_journal.page_entry (pagex).fp = rel (addr (dm_journal.page_entry (pagex + 1)));
	     end;
	end;

MAIN_RETURN:
	return;
%page;
FINISH:
     proc ();

	call terminate_file_ (dm_journal_segp, (0), "0"b, p_code);
	call cu_$level_set (save_level);
     end FINISH;
%skip (2);
ERROR_RETURN:
     proc ();

	call FINISH ();
	goto MAIN_RETURN;
     end ERROR_RETURN;
%include dm_journal_seg_;
%page; %include access_mode_values;
%page; %include terminate_file;

     end dm_init_from_hardcore_;




		    dm_initializer_.pl1             03/06/85  0751.0re  03/05/85  0755.9       83061



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

/*  DESCRIPTION:

	This implements dm_daemon_util_$initialize_system.

	Per-System Initializer for Data Management (actually, per-AIM
     authorization).  This program is called through a privileged gate once
     per bootload for each AIM authorization for which Data Management is 
     enabled.  It does the following (but the work is done elsewhere):

    1. Initializes a per-system directory for this bootload.

    2. Calls various initialization programs. If any return an error,
       it gives up.

    3. Enables Data Management.
*/

/*  HISTORY:

Written by J. Bongiovanni, 08/01/82.
Modified:
08/17/82 by M. Pandolf: to add transaction manager initialization.
09/16/82 by M. Pandolf:  to add p_init_str_ptr to parameter list and to
	  initialize dm_system_data_$initializer_event_chn.
11/11/82 by L. A. Newcomb:  to add call to dm_per_system_$recovery.
05/17/83 by L. A. Newcomb:  Fixed up calls to the various initializing
	  programs to match the modifications to them for the per-AIM
	  control files.  Adoption of an orphaned, but running DMS is now
	  handled.  p_code was removed from dm_initializer entry sequence.
07/25/83 by M. Pandolf: eliminated terminate_segno entrypoint.
10/19/83 by Lindsey L. Spratt:  Fixed to always do a dm_common_init_ (to force
            per-process initialization), per-process initialization wasn't
            being done in the case where a running DM system was being taken
            over.
03/05/84 by Lee A. Newcomb:  to use the include file dm_system_states
	  (renamed from dm_statuses), and the renamed values therein.
09/29/84 by Lee A. Newcomb:  added call to schedule DMS shutdown after
            enabling the DMS and fixed error msg for part 1 BJM init to
            include "part 1" in it, and addressed audit comments.
11/26/84 by Matthew Pierret:  Changed to call
	  transaction_manager_$per_process_init instead of
            the obsolete dm_common_init_.
12/04/84 by Lee A. Newcomb:  Removed obsolete parameter from call to
            dm_per_system_$enable; added use of (ERROR MAIN)_RETURN mechanism;
            and some minor restructuring.
12/05/84 by Stanford S. Cox: Added 'dm' prefix to init_from_hardcore_.
12/11/84 by Lee A. Newcomb:  Changed to send system_shutdown_scheduled_ IPS to
	  Daemon instead of trying to setup DM shutdown here because we
	  should schedule in the login ring, not the DM ring.
12/13/84 by R. Michael Tague: Changed name of dm_system_init_str.incl.pl1 to
            dm_system_init_info.incl.pl1.
01/13/85 by Lee A. Newcomb:  Fixed to not send the system_shutdown_scheduled_
            IPS to the executing process; there is a window when caller has
            not changed the static handler and the dmsd_overseer_ module is
            responsible for setting up shutdown.
*/
/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;
dm_initializer_:
   proc (p_init_info_ptr);

/* START OF DECLARATIONS */

/*  Parameter  */
dcl  p_init_info_ptr		ptr		/* to initialization structure */
				parameter;

/*  Automatic  */
dcl  (
     code				fixed bin (35),
     saved_level			fixed bin
     )				automatic;

/* Based */
/* Builtin */
dcl  (addr, null)			builtin;

/* Condition */
dcl  cleanup			condition;

/* Constants */
dcl  (
     IOA_GENERAL_RS_NO_NEW_LINE	bit (1) aligned init ("0"b),
     IOA_GENERAL_RS_DONT_PAD		bit (1) aligned init ("1"b),
     myname			char (15) init ("dm_initializer_")
     )				int static options (constant);

/*  Entry  */
dcl  (
     before_journal_manager_$per_system_init_1
				entry (fixed bin (35)),
     before_journal_manager_$per_system_init_2
				entry (fixed bin (35)),
     cu_$arg_list_ptr		entry (ptr),
     cu_$level_get			entry (fixed bin),
     cu_$level_set			entry (fixed bin),
     dm_init_from_hardcore_		entry (fixed bin (35)),
     dm_per_system_$cleanup		entry (),
     dm_per_system_$enable		entry (),
     dm_per_system_$init		entry (fixed bin (71))
				returns (char (4) aligned),
     dm_recovery_			entry (),
     file_manager_$per_system_init	entry (fixed bin (35)),
     get_process_id_		entry () returns (bit (36)),
     get_ring_			entry () returns (fixed bin (3)),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned),
     lock_manager_$init_per_system	entry (fixed bin (35)),
     sub_err_			entry () options (variable),
     transaction_manager_$per_process_init
				entry (),
     transaction_manager_$per_system_init
				entry (fixed bin (35))
     )				external;

/* External */
dcl  error_table_$unimplemented_version fixed bin (35) external static;
%page;
/* First, validate the input initialization structure. */

   dm_system_init_info_ptr = p_init_info_ptr;
   if dm_system_init_info.version ^= DM_SYSTEM_INIT_INFO_VERSION_1 then
      call ERROR_RETURN (error_table_$unimplemented_version,
	 "^/System initialization structure has version ^a, not ^a.",
	 dm_system_init_info.version, DM_SYSTEM_INIT_INFO_VERSION_1);

   call cu_$level_get (saved_level);			/* first the cleanup handler */
   on cleanup
      begin;					/* must be able to work */
						/* In keeping with the spirit of this program, the work */
						/*     is done elsewhere. */
         call dm_per_system_$cleanup ();
         call cu_$level_set (saved_level);
      end;
   call cu_$level_set (get_ring_ ());

/* Call dm_per_system_$init to create a temporary per-bootload directory.   */
/* If the state returned indicates DMS is running, we have taken over an    */
/* existing DMS from a dead caretaker Daemon.  In ALL other cases, we       */
/* must call the SETUP_DATA_MANAGEMENT internal procedure to create the     */
/* base from which to boot a new DMS.  Note the use of the running state is */
/* to indicate the DMS is active, the actual states may be running, or one  */
/* of the shutdown states besides normal shutdown.		      */

   if dm_per_system_$init (dm_system_init_info.event_channel)
        ^= DM_SYSTEM_STATE_RUNNING then
      call SETUP_DATA_MANAGEMENT ();
   call transaction_manager_$per_process_init ();		/* do per-process init */

   call cu_$level_set (saved_level);

MAIN_RETURN:
   return;
%page;
SETUP_DATA_MANAGEMENT:
   proc ();

/*  Call various subsystem initialization programs  which	*/
/*  do not assume an operable Data Management system.	*/

   call dm_init_from_hardcore_ (code);
   if code ^= 0 then
      call ERROR_RETURN (code, "^/Call to dm_init_from_hardcore_ failed.");

   call lock_manager_$init_per_system (code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "^/Unable to do lock manager per-system initialization.");

   call transaction_manager_$per_system_init (code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "^/Unable to do transaction manager per-system initialization.");

   call file_manager_$per_system_init (code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "^/Unable to do file manager per-system initialization.");

   call before_journal_manager_$per_system_init_1 (code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "^/Unable to do part 1 before journal manager per-system initialization."
	 );
%page;
/* Now call in the recovery procedure.  This call is made unconditionally; */
/* the recovery programs take into account all the various per-AIM control */
/* file indicators like if recovery is to be done, non-fatal error handling, */
/* holding old bootload directories for later inspection, etc.  The sub_err_ */
/* procedure is used for reporting fatal recovery errors. */

   call dm_recovery_ ();

/*  Call initialization routines which depend on an operable Data */
/*     Management system. */

   call before_journal_manager_$per_system_init_2 (code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "^/Unable to do part 2 before journal manager per-system initialization."
	 );

/*  Enable Data Management  */

   call dm_per_system_$enable ();


   return;

   end SETUP_DATA_MANAGEMENT;
%page;
ERROR_RETURN:
   proc options (variable);

dcl  (
     er_arg_list_ptr		ptr,
     er_code			fixed bin (35),
     er_message			char (1024),
     er_message_length		fixed bin (21)
     )				automatic;

dcl  (
     er_fixed_bin_35_value		fixed bin (35),
     er_message_overlay		char (er_message_length)
     )				based;

   call cu_$arg_list_ptr (er_arg_list_ptr);
   er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_fixed_bin_35_value;

   call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message, er_message_length,
        IOA_GENERAL_RS_DONT_PAD, IOA_GENERAL_RS_NO_NEW_LINE);
   call sub_err_ (er_code, myname, ACTION_CANT_RESTART, null (), 0,
        addr (er_message) -> er_message_overlay);

   end ERROR_RETURN;
%page;
%include dm_system_init_info;
%page;
%include dm_system_states;
%page;
%include arg_list;
%page;
%include sub_err_flags;


   end dm_initializer_;




		    dm_load_configuration_.pl1      01/04/85  0952.6re  01/03/85  1150.4       51714



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

/* format: ^indcom */

/* DESCRIPTION:

         This  program  loads  dm_system_data_ with the various configuration
     file parameters that are different than in the installed dm_system_data_.
     An example of this is the default before journal size.

     Several assumptions are made:
     - The configuration file exists and has been locked and validated by  the
       process loading the system data,
     - dm_system_data_ is addressable via an implicit link,
     -  the configuration file can be interpreted by overlaying a structure on
       it (see dm_system_config.incl.pl1), and
     - the site config parameters will  either  be  zero  (a.k.a.    null)  or
       non-zero.    Zero  valued parameters will be ignored, the others loaded
       into dm_system_data_.
*/

/* HISTORY:
Written by M. Pandolf, 12/07/82.
Modified:
03/21/83 by M. Pandolf: to use new dm_system_config dcl and to use new name
	  use new name for the config file, "dm_configuration".
03/23/83 by M. Pandolf: to set default bj dirs and to set shutdown delay.
03/28/83 by M. Pandolf: to fix names of default bj dirs and to add
	  log_proc_terms.
04/07/83 by M. Pandolf:  to fix bug in previous change.
05/09/83 by L. A. Newcomb:  to work with new config programs:  lock and find.
11/04/83 by M. Pandolf:  to set default before journal name to
            system_default.bj for extended object integration.
05/29/84 by Lindsey L. Spratt:  Changed to use version 2 of dm_system_config.
            Fixed to check the version of dm_system_config.  Removed dcl of
            $bj_max_n_journals.
06/12/84 by Lindsey Spratt:  Added initialization of the
	  $initializer_shutdown_delay cell.
09/05/84 by Lee A. Newcomb:  Renamed
            dm_system_data_$initializer_shutdown_delay to be
            $user_shutdown_delay to agree with dm_system_data_ changes.
11/22/84 by Lee A. Newcomb:  Fixed to use dm_misc_util_$get_aim_dir.
12/10/84 by R. Michael Tague:  Added comments and rearranged CHECK_VERSION args
*/

/* format: style2,^inddcls,linecom,ifthendo,ifthen,^indnoniterdo,dclind5,idind35 */

dm_load_configuration_:
     proc (p_dm_system_config_ptr);

/* START OF DECLARATIONS */

/* Parameter */
dcl  p_dm_system_config_ptr		ptr parameter;

/* Automatic */
dcl  code				fixed bin (35) automatic;

/* Builtin */
dcl  null				builtin;

/* Constant */
dcl  myname			init ("dm_load_configuration_") char (32) varying internal static
				options (constant);

/* Entries */
dcl  (
     dm_misc_util_$get_aim_dir	entry (char (*)),
     sub_err_			entry () options (variable)
     )				external;

/* External */
dcl  (
     dm_system_data_$bj_default_dirname char (168),
     dm_system_data_$bj_default_filename
				char (32),
     dm_system_data_$bj_default_journal_size
				fixed bin,
     dm_system_data_$bj_max_n_processes fixed bin,
     dm_system_data_$initializer_wakeup_increment
				fixed bin,
     dm_system_data_$log_proc_terms	bit (1) aligned,
     dm_system_data_$max_n_transactions fixed bin,
     dm_system_data_$user_shutdown_delay
				fixed bin (71),
     error_table_$unimplemented_version fixed bin (35)
     )				external static;

/* END OF DECLARATIONS */
%page;
/* set local version of config file pointer */

	dm_system_config_ptr = p_dm_system_config_ptr;

	call CHECK_VERSION (dm_system_config.version, DM_CONFIG_VERSION_2, "dm_system_config");

/* now fill in appropriate dm_system_data_ cells. */

	if dm_system_config.idle_timeout ^= 0 then
	     dm_system_data_$initializer_wakeup_increment = dm_system_config.idle_timeout;

	if dm_system_config.shutdown_delay ^= 0 then
	     dm_system_data_$user_shutdown_delay = dm_system_config.shutdown_delay;

/* $log_proc_terms is always set, no default */

	dm_system_data_$log_proc_terms = dm_system_config.log_proc_terms;

	if dm_system_config.max_n_txn ^= 0 then
	     dm_system_data_$max_n_transactions = dm_system_config.max_n_txn;

	if dm_system_config.max_n_proc ^= 0 then
	     dm_system_data_$bj_max_n_processes = dm_system_config.max_n_proc;

	if dm_system_config.default_bj_size ^= 0 then
	     dm_system_data_$bj_default_journal_size = dm_system_config.default_bj_size;

	if dm_system_config.default_bj.dir = "" | dm_system_config.default_bj.dir = "aim_dir" then
	     call dm_misc_util_$get_aim_dir (dm_system_data_$bj_default_dirname);

/*
   NOTE WELL: the non-deterministic keyword "bootload_dir" is passed directly
   into dm_system_data_ to be interpreted at a later time by the before 
   journal manager.
*/

	else dm_system_data_$bj_default_dirname = dm_system_config.default_bj.dir;

	if dm_system_config.default_bj.entry = "" then
	     dm_system_data_$bj_default_filename = "system_default.bj";
	else dm_system_data_$bj_default_filename = dm_system_config.default_bj.entry;

	return;
%page;
CHECK_VERSION:
     proc (p_received_version, p_expected_version, p_structure_name);

dcl  (p_expected_version, p_received_version)
				char (8) aligned parameter;
dcl  p_structure_name		char (*) parameter;

	if p_expected_version ^= p_received_version then
	     call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
		"^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", p_expected_version, p_structure_name, p_received_version);
     end CHECK_VERSION;


/* INCLUDE FILES START NEXT PAGE */
%page;
%include dm_system_config;
%page;
%include sub_err_flags;


     end dm_load_configuration_;




		    dm_lock_configuration_.pl1      04/04/85  1114.9re  04/04/85  0824.6       43101



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

/* DESCRIPTION:

         This  program  locks  the DM configuration file for a particular AIM
     level.  The process must have previously called dm_find_configuration_ to
     get a pointer to the configuration file.  The set_lock_ system subroutine
     is used to lock the file against any other use of  the  file  by  another
     process  attempting  to bootload a DMS at the same AIM level, or a system
     administrator trying  to  install  a  new  configuration  part  way  into
     initialization.

	The unlock entry gives up the ability of the process to read the
     config file AND be guaranteed the data is valid.
*/

/* HISTORY:

Written by L. A. Newcomb, 05/09/83.
Modified:
05/09/83 by L. A. Newcomb:  Added unlock entry.
06/06/84 by Lindsey L. Spratt:  Changed to check for the version of the
            dm_system_config structure.
02/20/85 by Lee A. Newcomb:  Corrected the order of CHECK_VERSION's
            parameters; added detection of inability to lock at all; and fixed
            error message for unlocking failure.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
*/
/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo,^inddcls,dclind5,idind35,linecom */
%page;
dm_lock_configuration_:
   proc (p_dm_system_config_ptr);

/* DECLARATIONS */

/* Parameter */
dcl  p_dm_system_config_ptr		ptr		/* Loc. of curr. AIM level config file */
				parameter;

/* Automatic */
dcl  code				fixed bin (35) automatic;

/* Based */
/* Builtin */
dcl  null				builtin;

/* Condition */
/* Constant */
dcl  myname			init ("dm_lock_configuration_")
				char (32) varying internal
				static options (constant);

/* Entry */
dcl  (
     dm_misc_util_$log		entry options (variable),
     set_lock_$lock			entry (bit (36) aligned, fixed bin,
				fixed bin (35)),
     set_lock_$unlock		entry (bit (36) aligned,
				fixed bin (35)),
     sub_err_			entry () options (variable)
     )				external;

/* External */
dcl  (
     error_table_$invalid_lock_reset,
     error_table_$locked_by_this_process,
     error_table_$unimplemented_version
     )				fixed bin (35) external static;

/* Static */

/* END OF DECLARATIONS */
%page;
/* dm_lock_configuration_:			repeat for reader	*/
/*      proc (p_dm_system_config_ptr);				*/

/* Set local pointer for ease of use */

   dm_system_config_ptr = p_dm_system_config_ptr;
   call CHECK_VERSION (dm_system_config.version, DM_CONFIG_VERSION_2,
        "dm_system_config");

/* Now lock the file, reporting interesting statuses */

   call set_lock_$lock (dm_system_config.lock, 0, code);
   if code = error_table_$invalid_lock_reset then
      call dm_misc_util_$log (LOG_SV, code, myname,
	 "Warning: DM config file locked from invalid process.");
   else if code = error_table_$locked_by_this_process then	/* logic error */
      call sub_err_ (code, myname, ACTION_CANT_RESTART, null (), 0,
	 "DM initialization logic error: cannot lock config more than once.")
	 ;
   else if code ^= 0 then
      call sub_err_ (code, myname, ACTION_CANT_RESTART, null (), 0,
	 "Could not lock DM config file.");

   return;

/* end dm_lock_configuraiton_; */
%skip (4);
dm_lock_configuration_$unlock:
   entry (p_dm_system_config_ptr);

/* copy parameter to local and init local status code */

   dm_system_config_ptr = p_dm_system_config_ptr;
   call CHECK_VERSION (dm_system_config.version, DM_CONFIG_VERSION_2,
        "dm_system_config");

/* Now unlock the config and report any interesting statuses */

   call set_lock_$unlock (dm_system_config.lock, code);
   if code ^= 0 then				/* fatal initialization error */
      call sub_err_ (code, myname, ACTION_CANT_RESTART, null (), 0,
	 "Attempting to unlock system config file.");

   return;

/* end dm_lock_configuration_$unlock; */
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

dcl  (
     (cv_p_expected_version, cv_p_received_version)
				char (8) aligned,
     cv_p_structure_name		char (*)
     )				parameter;

   if cv_p_expected_version ^= cv_p_received_version then
      call sub_err_ (error_table_$unimplemented_version, myname,
	 ACTION_CANT_RESTART, null, 0,
	 "^/Expected version ^a of the ^a structure.  
Received version ^a, instead.", cv_p_expected_version, cv_p_structure_name,
	 cv_p_received_version);
   end CHECK_VERSION;
%page;
%include dm_system_config;
%page;
%include dm_log_sv_codes;
%page;
%include sub_err_flags;


   end dm_lock_configuration_;




		    dm_lock_meters.pl1              04/04/85  1114.9re  04/04/85  0824.8      193932



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

/* DESCRIPTION:

Syntax:  dm_lock_meters {-control_args}


Function:  This command displays metering information about Data
Management locking.


Control arguments:
-reset, -rs
   resets the meters to zero and suppresses reporting.
-report_reset, -rr
   reports the current meters then resets them.
-brief, -bf
   selects the brief format for reporting on locking.  (DEFAULT)
-long, -lg
   selects the long format for reporting on locking.


Notes:  This command requires e (execute) access to dm_admin_gate_.


Examples:  Following are two example invocations of this command.  The
first is the default output (the -brief format), the second is the long
output.

 !  dm_lock_meters

    Total metering time:  3:09:51

    Calls to per system lock:      208.
    Calls to unlock all:           208.
    Locks by mode:
                          S       X      IS      IX     SIX
        FILES:            0     154       3      51       0
         CI'S:            0       0

    Waits for locks:               0.
    Deadlocks:
     Total Deadlock checks:        0.
     Deadlocks detected:           0.



 !  dm_lock_meters -lg

    Total metering time:  3:09:51



    Calls to per system lock:      208.
    Calls to unlock all:           208.
    Locks by mode:
                          S       X      IS      IX     SIX
    NEW FILES:            0     154       3      51       0
    OLD FILES:            0       0       0       0       0
                   ---------------------------------------------------------
        FILES:            0     154       3      51       0

     NEW CI'S:            0       0
     OLD CI'S:            0       0
                   ---------------------------------------------------------
         CI'S:            0       0

    Waits for locks:               0.
    Deadlocks:
     Total Deadlock checks:        0.
     Two or more transactions:     0.
     36 or less transactions:      0.
     36 to 72 transactions:        0.
     More than 72 transactions:    0.
     Deadlocks detected:           0.
       Self youngest:              0.
       Other youngest:             0.

    Lock segments:                 1. (max size 4096.)
    Block allocates:               416.
    Block frees:                   416.
*/

/* HISTORY:

Written by BIM, 04/15/83.
Modified:
05/01/84 by R. Michael Tague:  Added the History section.  Added
            %include dm_lm_meters.
10/23/84 by Stanford S. Cox:  To check lock_seg and lock_meters versions.
12/01/84 by Lindsey L. Spratt:  Major reconstruction of the program.  Changed
            the argument processing, added the brief/long report format
            distinction, added the saved_lock_seg (and its resetting), added
            the total metering time display.
12/05/84 by Lindsey L. Spratt:  Fixed some mis-named report_format_selection
            variables in RCM to have the rcm_p_ prefix.  Fixed FINISH to
            destroy the invocation.  Added documentation.
03/19/85 by S. Cox: Added dm_not_available_ handler.
*/
/* format: style2,ind3 */
%page;
dm_lock_meters:
   proc ();

/* START OF DECLARATIONS */
/* Automatic */

      dcl	    accept_control_argument
			       bit (1) aligned init ("0"b);
      dcl	    arg_idx	       fixed bin;
      dcl	    arg_len	       fixed bin (21);
      dcl	    arg_list_ptr	       ptr init (null);
      dcl	    arg_ptr	       ptr;
      dcl	    code		       fixed bin (35);
      dcl	    control_argument_idx   fixed bin;
      dcl	    current_time	       fixed bin (71) init (0);
      dcl	    force_interpretation_as_argument
			       bit (1) aligned init (NO);
      dcl	    is_active_function     bit (1) aligned init (NO);
      dcl	    number_of_args	       fixed bin;
      dcl	    report_current_meters  bit (1) aligned init (YES);
      dcl	    report_format_selection
			       bit (1) aligned init (BRIEF_FORMAT);
      dcl	    reset_saved_meters     bit (1) aligned init (NO);
      dcl	    return_arg_len	       fixed bin (21) init (0);
      dcl	    return_arg_ptr	       ptr init (null);
      dcl	    sci_ptr	       ptr init (null);
      dcl	    this_is_a_standalone_invocation
			       bit (1) aligned init (YES);
      dcl	    tsp		       pointer;

/* Based */

      dcl	    arg		       char (arg_len) based (arg_ptr);

/* Builtin */

      dcl	    (clock, null)	       builtin;

/* Condition */

      dcl	    (cleanup, dm_not_available_)
			       condition;

/* Constant */

      dcl	    (
	    YES		       init ("1"b),
	    NO		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);

      dcl	    (
	    BRIEF_FORMAT	       init ("0"b),
	    LONG_FORMAT	       init ("1"b)
	    )		       bit (1) aligned internal static options (constant);

      dcl	    myname	       init ("dm_lock_meters") char (14) internal static options (constant);

      dcl	    (
	    MICROSECONDS_PER_SECOND
			       init (1e6),
	    MINUTES_PER_HOUR       init (60),
	    SECONDS_PER_HOUR       init (3600),
	    SECONDS_PER_MINUTE     init (60)
	    )		       fixed bin (35) internal static options (constant);

      dcl	    ARGUMENT_TYPE	       (8) internal static options (constant) char (64) varying
			       init ("", "", "", "", "", "", "", "");
      dcl	    CONTROL_ARGUMENT       (8) internal static options (constant) char (64) varying
			       init ("-reset", "-rs", "-report_reset", "-rr", "-brief", "-bf", "-long", "-lg");

/* Entry */


      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    dm_misc_util_$get_initialization_time
			       entry () returns (fixed bin (71));
      dcl	    get_temp_segment_      entry (char (*), ptr, fixed bin (35));
      dcl	    ioa_		       entry options (variable);
      dcl	    lock_manager_$copy_data
			       entry (pointer, fixed bin (35));
      dcl	    release_temp_segment_  entry (char (*), ptr, fixed bin (35));
      dcl	    ssu_$abort_line	       entry () options (variable);
      dcl	    ssu_$arg_ptr	       entry (ptr, fixed bin, ptr, fixed bin (21));
      dcl	    ssu_$destroy_invocation
			       entry (ptr);
      dcl	    ssu_$return_arg	       entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21));
      dcl	    ssu_$standalone_invocation
			       entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    dm_error_$system_not_initialized,
	    error_table_$active_function,
	    error_table_$bad_arg,
	    error_table_$badopt,
	    error_table_$noarg,
	    error_table_$smallarg,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) external;

      dcl	    dm_system_data_$max_n_transactions
			       ext static fixed bin;


/* Static */

      dcl	    saved_lock_seg_ptr     ptr internal static init (null);
      dcl	    saved_time	       fixed bin (71) init (0) internal static;

/* END OF DECLARATIONS */
      lm_copy_data_ptr = null ();
      tsp = null ();
      on cleanup call CLEANUP ();

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on dm_not_available_ call ssu_$abort_line (sci_ptr, dm_error_$system_not_initialized);

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

      if is_active_function
      then call ssu_$abort_line (sci_ptr, error_table_$active_function, myname);

      accept_control_argument = YES;
      control_argument_idx = -1;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to number_of_args;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES
         then call PROCESS_ARGUMENT (arg, control_argument_idx, accept_control_argument);
         else if accept_control_argument = YES
         then call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx, accept_control_argument,
	         force_interpretation_as_argument);
         else call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	         CONTROL_ARGUMENT (control_argument_idx),
	         (index ("aeiouh", substr (ARGUMENT_TYPE (control_argument_idx), 1, 1)) > 0),
	         ARGUMENT_TYPE (control_argument_idx));
      end ARG_PROCESSING_LOOP;

      if control_argument_idx >= 0 & accept_control_argument = NO
      then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	      CONTROL_ARGUMENT (control_argument_idx),
	      (index ("aeiouh", substr (ARGUMENT_TYPE (control_argument_idx), 1, 1)) > 0),
	      ARGUMENT_TYPE (control_argument_idx));
%page;
      lm_copy_data_n_segments = 1;			/* just the first has meters */
      allocate lm_copy_data;
      lm_copy_data.version = LM_COPY_DATA_VERSION_1;
      lm_copy_data.n_segments = 1;
      call get_temp_segment_ (myname, tsp, (0));
      lm_copy_data.segment_ptrs (1) = tsp;

      current_time = clock ();

      call lock_manager_$copy_data (addr (lm_copy_data), code);
      if code ^= 0
      then if code ^= error_table_$smallarg
	 then call ssu_$abort_line (sci_ptr, code, "^/Unable to copy the lock metering data.");

/**** Okay, we now have meters. ***/

      lock_seg_ptr = tsp;
      call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
      call CHECK_VERSION (LOCK_METERS_VERSION_1, lock_seg.meters.version, "lock_meters");

      if saved_lock_seg_ptr = null
      then call INIT_SAVED_LOCK_METERS (lock_seg_ptr, saved_lock_seg_ptr, saved_time);

      if report_current_meters = YES
      then call REPORT_CURRENT_METERS (report_format_selection, lock_seg_ptr, current_time, saved_lock_seg_ptr,
	      saved_time);

      if reset_saved_meters = YES
      then call RESET_SAVED_METERS (lock_seg_ptr, current_time, saved_lock_seg_ptr, saved_time);

      call FINISH ();

MAIN_RETURN:
      return;
%page;
ABORT_ENTRY:
   procedure ();
      call CLEANUP ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;



CLEANUP:
   procedure ();
      call FINISH ();
   end CLEANUP;

FINISH:
   proc ();
      call ssu_$destroy_invocation (sci_ptr);
      if tsp ^= null ()
      then call release_temp_segment_ (myname, tsp, (0));
      if lm_copy_data_ptr ^= null ()
      then free lm_copy_data;
   end FINISH;

PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

      dcl	    pa_p_arg	       char (*) parm;
      dcl	    pa_p_control_argument_idx
			       fixed bin parm;
      dcl	    pa_p_accept_control_argument
			       bit (1) aligned parm;

      dcl	    pa_code	       fixed bin (35);

      pa_code = 0;

      goto ARGUMENT (pa_p_control_argument_idx);
ARGUMENT (-1):
      call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The argument ""^a"" is out of place.", arg);
      return;
   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument, pca_p_force_interpretation_as_argument);


      dcl	    pca_p_arg	       char (*) parm;
      dcl	    pca_p_control_argument_idx
			       fixed bin parm;
      dcl	    pca_p_accept_control_argument
			       bit (1) aligned parm;
      dcl	    pca_p_force_interpretation_as_argument
			       bit (1) aligned parm;

      pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
      pca_p_accept_control_argument = YES;
      pca_p_force_interpretation_as_argument = NO;

      go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
      call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* -reset */
CONTROL_ARGUMENT (2):				/* -rs */
      reset_saved_meters = YES;
      report_current_meters = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (3):				/* -report_reset */
CONTROL_ARGUMENT (4):				/* -rr */
      reset_saved_meters = YES;
      report_current_meters = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (5):				/* -brief */
CONTROL_ARGUMENT (6):				/* -bf */
      report_format_selection = BRIEF_FORMAT;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (7):				/* -long */
CONTROL_ARGUMENT (8):				/* -lg */
      report_format_selection = LONG_FORMAT;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


   end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

      dcl	    cai_p_arg	       char (*);
      dcl	    cai_control_argument_idx
			       fixed bin;

      do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	 while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
      end;
      if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
      then return (-1);
      else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;


DISPLAY_TOTAL_METERING_TIME:
   proc (dtmt_p_duration_in_microseconds);
      dcl	    dtmt_p_duration_in_microseconds
			       fixed bin (71) parm;

      dcl	    dtmt_duration_in_seconds
			       fixed bin (71);
      dcl	    dtmt_hours	       fixed bin (71);
      dcl	    dtmt_minutes	       fixed bin (71);
      dcl	    dtmt_seconds	       fixed bin (71);

      dtmt_duration_in_seconds = divide (dtmt_p_duration_in_microseconds, MICROSECONDS_PER_SECOND, 71, 0);
      dtmt_seconds = mod (dtmt_duration_in_seconds, SECONDS_PER_MINUTE);
      dtmt_minutes = mod (divide (dtmt_duration_in_seconds, SECONDS_PER_MINUTE, 71, 0), MINUTES_PER_HOUR);
      dtmt_hours = divide (dtmt_duration_in_seconds, SECONDS_PER_HOUR, 71, 0);

      call ioa_ ("^/Total metering time:^2x^i:^[0^]^i:^[0^]^i^/", dtmt_hours, (dtmt_minutes < 10), dtmt_minutes,
	 (dtmt_seconds < 10), dtmt_seconds);

   end DISPLAY_TOTAL_METERING_TIME;



INIT_SAVED_LOCK_METERS:
   proc (islm_p_current_lock_seg_ptr, islm_p_saved_lock_seg_ptr, islm_p_saved_time);
      dcl	    islm_p_current_lock_seg_ptr
			       ptr parm;
      dcl	    islm_p_saved_lock_seg_ptr
			       ptr parm;
      dcl	    islm_p_saved_time      fixed bin (71) parm;

      dcl	    islm_code	       fixed bin (35) init (0);

      islm_p_saved_time = dm_misc_util_$get_initialization_time ();

      call get_temp_segment_ (myname, islm_p_saved_lock_seg_ptr, islm_code);
      if islm_code ^= 0
      then call ssu_$abort_line (sci_ptr, islm_code,
	      "^/Unable to get temp segment to hold the saved copy of the lock meters.");

      islm_p_saved_lock_seg_ptr -> lock_seg = islm_p_current_lock_seg_ptr -> lock_seg;
      unspec (islm_p_saved_lock_seg_ptr -> lock_seg.meters.lm_meters) = "0"b;

   end INIT_SAVED_LOCK_METERS;


REPORT_CURRENT_METERS:
   proc (rcm_p_report_format_selection, rcm_p_current_lock_seg_ptr, rcm_p_current_time, rcm_p_saved_lock_seg_ptr,
        rcm_p_saved_time);
      dcl	    rcm_p_report_format_selection
			       bit (1) aligned parm;
      dcl	    rcm_p_current_lock_seg_ptr
			       ptr parm;
      dcl	    rcm_p_current_time     fixed bin (71) parm;
      dcl	    rcm_p_saved_lock_seg_ptr
			       ptr parm;
      dcl	    rcm_p_saved_time       fixed bin (71) parm;

      dcl	    1 rcm_p_current_lock_seg
			       aligned like lock_seg based (rcm_p_current_lock_seg_ptr);
      dcl	    1 rcm_p_saved_lock_seg aligned like lock_seg based (rcm_p_saved_lock_seg_ptr);

      call DISPLAY_TOTAL_METERING_TIME (rcm_p_current_time - rcm_p_saved_time);

      call ioa_ ("Calls to per system lock:^32t^d.",
	 rcm_p_current_lock_seg.meters.lock_calls - rcm_p_saved_lock_seg.meters.lock_calls);
      call ioa_ ("Calls to unlock all:^32t^d.",
	 rcm_p_current_lock_seg.meters.unlock_all_calls - rcm_p_saved_lock_seg.meters.unlock_all_calls);
      call ioa_ ("Locks by mode:");
      call ioa_ ("^20x^(^3a^5x^)", LOCK_MODE_NAMES);
      if rcm_p_report_format_selection = LONG_FORMAT
      then
         do;
	  call ioa_ ("NEW FILES:^5x^(^8d^)",
	       (rcm_p_current_lock_seg.meters.file_locks_by_mode - rcm_p_saved_lock_seg.meters.file_locks_by_mode)
	       - (rcm_p_current_lock_seg.meters.dup_file_locks_by_mode
	       - rcm_p_saved_lock_seg.meters.dup_file_locks_by_mode));
	  call ioa_ ("OLD FILES:^5x^(^8d^)",
	       rcm_p_current_lock_seg.meters.dup_file_locks_by_mode
	       - rcm_p_saved_lock_seg.meters.dup_file_locks_by_mode);
	  call ioa_ ("^15x---------------------------------------------------------");
         end;
      call ioa_ ("    FILES:^5x^(^8d^)",
	 rcm_p_current_lock_seg.meters.file_locks_by_mode - rcm_p_saved_lock_seg.meters.file_locks_by_mode);
      if rcm_p_report_format_selection = LONG_FORMAT
      then
         do;
	  call ioa_;

	  call ioa_ (" NEW CI'S:^5x^(^8d^)",
	       (rcm_p_current_lock_seg.meters.ci_locks_by_mode - rcm_p_saved_lock_seg.meters.ci_locks_by_mode)
	       - (rcm_p_current_lock_seg.meters.dup_ci_locks_by_mode - rcm_p_saved_lock_seg.meters.dup_ci_locks_by_mode)
	       );
	  call ioa_ (" OLD CI'S:^5x^(^8d^)",
	       rcm_p_current_lock_seg.meters.dup_ci_locks_by_mode - rcm_p_saved_lock_seg.meters.dup_ci_locks_by_mode);
	  call ioa_ ("^15x---------------------------------------------------------");
         end;
      call ioa_ ("     CI'S:^5x^(^8d^)",
	 rcm_p_current_lock_seg.meters.ci_locks_by_mode - rcm_p_saved_lock_seg.meters.ci_locks_by_mode);
      call ioa_;
      call ioa_ ("Waits for locks:^32t^d.", rcm_p_current_lock_seg.meters.waits - rcm_p_saved_lock_seg.meters.waits);
      call ioa_ ("Deadlocks:");
      call ioa_ (" Total Deadlock checks:^32t^d.",
	 rcm_p_current_lock_seg.meters.deadlock_checks - rcm_p_saved_lock_seg.meters.deadlock_checks);
      if rcm_p_report_format_selection = LONG_FORMAT
      then
         do;
	  call ioa_ (" Two or more transactions:^32t^d.",
	       rcm_p_current_lock_seg.meters.real_deadlock_checks - rcm_p_saved_lock_seg.meters.real_deadlock_checks);
	  call ioa_ (" 36 or less transactions:^32t^d.",
	       rcm_p_current_lock_seg.meters.deadlock_checks_36 - rcm_p_saved_lock_seg.meters.deadlock_checks_36);
	  call ioa_ (" 36 to 72 transactions:^32t^d.",
	       rcm_p_current_lock_seg.meters.deadlock_checks_72 - rcm_p_saved_lock_seg.meters.deadlock_checks_72);
	  call ioa_ (" More than 72 transactions:^32t^d.",
	       (rcm_p_current_lock_seg.meters.real_deadlock_checks - rcm_p_saved_lock_seg.meters.real_deadlock_checks)
	       - ((rcm_p_current_lock_seg.meters.deadlock_checks_36 - rcm_p_saved_lock_seg.meters.deadlock_checks_36)
	       + (rcm_p_current_lock_seg.meters.deadlock_checks_72 - rcm_p_saved_lock_seg.meters.deadlock_checks_72)));
         end;
      call ioa_ (" Deadlocks detected:^32t^d.",
	 (rcm_p_current_lock_seg.meters.deadlock_self_youngest - rcm_p_saved_lock_seg.meters.deadlock_self_youngest)
	 + (rcm_p_current_lock_seg.meters.deadlock_other_youngest - rcm_p_saved_lock_seg.meters.deadlock_other_youngest)
	 );
      if rcm_p_report_format_selection = LONG_FORMAT
      then
         do;
	  call ioa_ ("   Self youngest:^32t^d.",
	       rcm_p_current_lock_seg.meters.deadlock_self_youngest
	       - rcm_p_saved_lock_seg.meters.deadlock_self_youngest);
	  call ioa_ ("   Other youngest:^32t^d.",
	       rcm_p_current_lock_seg.meters.deadlock_other_youngest
	       - rcm_p_saved_lock_seg.meters.deadlock_other_youngest);
	  call ioa_ ();
	  call ioa_ ("Lock segments:^32t^d. (max size ^d.)", rcm_p_current_lock_seg.n_lock_segments,
	       rcm_p_current_lock_seg.lock_seg_size);
	  call ioa_ ("Block allocates:^32t^d.",
	       rcm_p_current_lock_seg.meters.allocates - rcm_p_saved_lock_seg.meters.allocates);
	  call ioa_ ("Block frees:^32t^d.", rcm_p_current_lock_seg.meters.frees - rcm_p_saved_lock_seg.meters.frees);
         end;
   end REPORT_CURRENT_METERS;


RESET_SAVED_METERS:
   proc (rsm_p_current_lock_seg_ptr, rsm_p_current_time, rsm_p_saved_lock_seg_ptr, rsm_p_saved_time);
      dcl	    rsm_p_current_lock_seg_ptr
			       ptr parm;
      dcl	    rsm_p_current_time     fixed bin (71) parm;
      dcl	    rsm_p_saved_lock_seg_ptr
			       ptr parm;
      dcl	    rsm_p_saved_time       fixed bin (71) parm;

      rsm_p_saved_lock_seg_ptr -> lock_seg = rsm_p_current_lock_seg_ptr -> lock_seg;
      rsm_p_saved_time = rsm_p_current_time;
   end RESET_SAVED_METERS;


CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

      dcl	    cv_p_expected_version  char (8) aligned parameter;
      dcl	    cv_p_received_version  char (8) aligned parameter;
      dcl	    cv_p_structure_name    char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/Expected version ^a of the ^a structure." || "^/Received version ^a instead.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;

%page;
%include dm_lm_system_data;
%page;
%include dm_lm_meters;
%page;
%include dm_lm_copy_data;
%page;
%include dm_lock_modes;
%include sub_err_flags;
   end dm_lock_meters;




		    dm_lock_status.pl1              04/04/85  1114.9re  04/04/85  0824.8      262287



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

/*  DESCRIPTION:
    Program to display the Data Management lock_seg. Data Management
    must be initialized for this process.

    dm_lock_status {-control_args}

    Control Arguments:
-all_transactions, -atxn
   displays lock data for all transactions.
-current_transaction, -ctxn
   displays lock data for the current transaction in the user's
   process.  (DEFAULT)
-file_locks, -flk
   displays file-level locks.  (DEFAULT)
-no_file_locks, -nflk
   suppresses the display of file-level locks.
-control_interval_locks, -cilk
   displays control-interval-level locks.  (DEFAULT)
-no_control_interval_locks, -ncilk
   suppresses the display of control-interval-level locks.
-header, -he
   displays data from the header of the lock database.
-no_header, -nhe
   suppresses the display of data from the header of the lock database.
   (DEFAULT)


Notes:  This command requires e (execute) access to the dm_admin_gate_.
*/

/* HISTORY:

Written by J. Bongiovanni, 11/01/82.
Modified:
12/01/82 by J. Bongiovanni:  For multi-segment lock data.
04/25/83 by Benson I. Margulies:  To add -file, interpret process ids.
04/29/83 by Benson I. Margulies:  To use lock_manager_$copy_data.
05/01/84 by R. Michael Tague:  Added the History section.  Added
            %include dm_lm_meters.
10/19/84 by Stanford S. Cox:  For DM program standards.
11/29/84 by Lindsey L. Spratt:  Renamed from display_lm_data to
            dm_lock_status.  Completely reconstructed the argument processing.
            Changed to be a ssu_ standalone invocation.
12/05/84 by Lindsey L. Spratt:  Added the REPORT_MISSING_ARGUMENT proc.
01/02/85 by Lindsey L. Spratt:  Changed to use
            hbound(lock_seg.transaction_table,1), instead of
            dm_system_data_$max_n_transactions.
           Changed to use more of ssu_'s services, where feasible;
            ssu_$get/release_area, ssu_$get/release_temp_segment.  Fixed the
            allocations to be done in ssu_area.  Added new internal proc,
            REPORT_INVALID_VIRTUAL_POINTER, and changed all reports of invalid
            virtual ptrs to use it.  This proc gives the invalid value, while
            the old messages did not.  Changed to use an "indent" variable in
            DISPLAY_LOCK and DISPLAY_TRANSACTION to specify the level of
            indentation of the messages.  Fixed variables in
            DISPLAY_TRANSACTION to have the dt_ prefix instead of the dp_
            prefix.

01/04/85 by Lindsey L. Spratt:  Added the DISPLAY_BLOCK_LIST internal proc to
            have a common subr for displaying the lists of waiters and owners.
02/08/85 by Lindsey L. Spratt:  Changed dcl of temp_string to have a length of
            (sys_info$max_seg_size-1)*4, to allow for the length word.
            Removed spurious check of "code" after call of
            ssu_$get_temp_segment.
03/19/85 by S. Cox: Added dm_not_available_ handler.
*/

/* format: style2,ind3 */
dm_lock_status:
   procedure options (variable);

/*  Automatic  */

      dcl	    accept_control_argument
			       bit (1) aligned init ("0"b);
      dcl	    arg_idx	       fixed bin;
      dcl	    arg_len	       fixed bin (21);
      dcl	    arg_list_ptr	       ptr init (null);
      dcl	    arg_ptr	       ptr;
      dcl	    cur_txn_id	       bit (36) aligned;
      dcl	    code		       fixed bin (35);
      dcl	    control_argument_idx   fixed bin;
      dcl	    display_control_interval_locks
			       bit (1) aligned init (YES);
      dcl	    display_file_locks     bit (1) aligned init (YES);
      dcl	    display_hash_table     bit (1) aligned init (NO);
      dcl	    display_header	       bit (1) aligned init (NO);
      dcl	    duplication_indicator_has_been_displayed
			       bit (1) aligned init (NO);
      dcl	    force_interpretation_as_argument
			       bit (1) aligned init (NO);
      dcl	    hash_table_idx	       fixed bin;
      dcl	    is_active_function     bit (1) aligned init (NO);
      dcl	    number_of_args	       fixed bin;
      dcl	    previous_bucket	       bit (36) aligned;
      dcl	    1 pdi		       aligned like print_data_info;
      dcl	    return_arg_len	       fixed bin (21) init (0);
      dcl	    return_arg_ptr	       ptr init (null);
      dcl	    sci_ptr	       ptr init (null);
      dcl	    ssu_area_ptr	       ptr init (null);
      dcl	    temp_string_ptr	       ptr init (null);
      dcl	    there_is_an_active_transaction
			       bit (1) aligned init (NO);
      dcl	    this_is_a_standalone_invocation
			       bit (1) aligned init (YES);
      dcl	    transaction_idx	       fixed bin;
      dcl	    transaction_selection  fixed bin (35) init (CURRENT_TRANSACTION);

/*  Based  */

      dcl	    arg		       char (arg_len) based (arg_ptr);
      dcl	    ssu_area	       area (1024) based (ssu_area_ptr);
      dcl	    temp_string	       char ((sys_info$max_seg_size - 1) * 4) varying based (temp_string_ptr);

/* Builtin */

      dcl	    (addr, bin, hbound, index, null, ptr, setwordno, substr, unspec)
			       builtin;

/* Condition */

      dcl	    (cleanup, dm_not_available_)
			       condition;

/* Constant */

      dcl	    myname	       init ("dm_lock_status") char (14) internal static options (constant);
      dcl	    (
	    YES		       init ("1"b),
	    NO		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);


      dcl	    (
	    ALL_TRANSACTIONS       init (1),
	    CURRENT_TRANSACTION    init (0)
	    )		       fixed bin (35) internal static options (constant);

      dcl	    FILE_LOCK_CI_NUMBER    init (-1) fixed bin (35) internal static options (constant);
      dcl	    DEFAULT_AREA_INFO_PTR  init (null) ptr internal static options (constant);

      dcl	    ARGUMENT_TYPE	       (20) internal static options (constant) char (64) varying
			       init ("", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "")
			       ;

      dcl	    CONTROL_ARGUMENT       (20) internal static options (constant) char (64) varying
			       init ("-all_transactions", "-atxn", "-current_transaction", "-ctxn", "-file_locks",
			       "-flk", "-no_file_locks", "-nflk", "-control_interval_locks", "-cilk",
			       "-no_control_interval_locks", "-ncilk", "-header", "-he", "-no_header", "-nhe",
			       "-hash_table", "-ht", "-no_hash_table", "-nht");


/*  External  */

      dcl	    (
	    dm_error_$no_current_transaction,
	    dm_error_$system_not_initialized,
	    error_table_$bad_arg,
	    error_table_$badopt,
	    error_table_$noarg,
	    error_table_$smallarg,
	    error_table_$unimplemented_version
	    )		       fixed bin (35) external;

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;

/*  Entry  */

      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    get_temp_segments_     entry (character (*), (*) pointer, fixed binary (35));
      dcl	    ioa_		       entry options (variable);
      dcl	    lock_manager_$copy_data
			       entry (ptr, fixed bin (35));
      dcl	    lock_manager_$system_segment_count
			       entry (fixed bin (35)) returns (fixed bin);
      dcl	    print_data_	       entry (character (*) var, pointer, fixed binary (35));
      dcl	    release_temp_segments_ entry (character (*), (*) pointer, fixed binary (35));
      dcl	    ssu_$abort_line	       entry () options (variable);
      dcl	    ssu_$arg_count	       entry (ptr, fixed bin);
      dcl	    ssu_$arg_ptr	       entry (ptr, fixed bin, ptr, fixed bin (21));
      dcl	    ssu_$destroy_invocation
			       entry (ptr);
      dcl	    ssu_$get_area	       entry (ptr, ptr, char (*), ptr);
      dcl	    ssu_$get_temp_segment  entry (ptr, char (*), ptr);
      dcl	    ssu_$release_area      entry (ptr, ptr);
      dcl	    ssu_$release_temp_segment
			       entry (ptr, ptr);
      dcl	    ssu_$standalone_invocation
			       entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    transaction_manager_$get_current_txn_id
			       entry (bit (36) aligned, fixed bin (35));
      dcl	    transaction_manager_$get_txn_info
			       entry (bit (36) aligned, ptr, fixed bin (35));

      pdi.version = print_data_info_version_1;
      pdi.indentation = 3;
      pdi.value_column = 30;
      pdi.output_switch = null ();
      pdi.octal = YES;
      pdi.intervals = "";

      lm_copy_data_ptr, lock_segments_ptr = null ();

      on cleanup call CLEANUP ();

      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on dm_not_available_ call ssu_$abort_line (sci_ptr, dm_error_$system_not_initialized);

      call ssu_$get_area (sci_ptr, DEFAULT_AREA_INFO_PTR, "", ssu_area_ptr);

      call ssu_$arg_count (sci_ptr, number_of_args);

      accept_control_argument = YES;
      control_argument_idx = -1;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to number_of_args;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES
         then call PROCESS_ARGUMENT (arg, control_argument_idx, accept_control_argument);
         else if accept_control_argument = YES
         then call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx, accept_control_argument,
	         force_interpretation_as_argument);
         else call REPORT_MISSING_ARGUMENT (control_argument_idx);
      end ARG_PROCESSING_LOOP;

      if control_argument_idx >= 0 & accept_control_argument = NO
      then call REPORT_MISSING_ARGUMENT (control_argument_idx);

      call GET_SEGMENT_PTRS ();

      if display_header
      then
         do;
	  call ssu_$get_temp_segment (sci_ptr, "", temp_string_ptr);

	  put data (lock_seg.version, lock_seg.header) string (temp_string);

	  call print_data_ (temp_string, addr (pdi), (0));

	  call ioa_;
         end;

      lock_hash_table_ptr = setwordno (lock_seg_ptr, lock_seg.hash_table_offset);
      if lock_hash_table_ptr ^= addr (lock_seg.hash_table)
      then call ioa_ ("hash table offset is wrong");
      else if display_hash_table
      then
         do;
	  hash_table_idx = 1;
	  previous_bucket = unspec (lock_hash_table.buckets (1));
	  call ioa_ ("Bucket ^20tPointer to first lock object.");
	  call ioa_ ("^d ^20t^w", hash_table_idx, unspec (lock_hash_table.buckets (hash_table_idx)));
	  do hash_table_idx = 2 to lock_seg.n_hash_table_entries - 1;
	     if previous_bucket ^= unspec (lock_hash_table.buckets (hash_table_idx))
	     then
	        do;
		 call ioa_ ("^d ^20t^w", hash_table_idx, unspec (lock_hash_table.buckets (hash_table_idx)));
		 previous_bucket = unspec (lock_hash_table.buckets (hash_table_idx));
		 duplication_indicator_has_been_displayed = NO;
	        end;
	     else if duplication_indicator_has_been_displayed = NO
	     then
	        do;
		 call ioa_ ("===");
		 duplication_indicator_has_been_displayed = YES;
	        end;
	  end;
	  call ioa_ ("^d ^20t^w", hash_table_idx, unspec (lock_hash_table.buckets (hash_table_idx)));
         end;

      cur_txn_id = ""b;				/* start somewhere in case of error */
      call transaction_manager_$get_current_txn_id (cur_txn_id, code);
      if code ^= 0
      then if cur_txn_id = "0"b & code ^= dm_error_$no_current_transaction
	 then call ssu_$abort_line (sci_ptr, code, "^/Unable to get the current transaction id.");

      there_is_an_active_transaction = NO;

      do transaction_idx = 1 to hbound (lock_seg.transaction_table, 1);
         lock_transaction_table_ptr = addr (lock_seg.transaction_table (transaction_idx));
         if (transaction_selection = ALL_TRANSACTIONS | lock_transaction_table.txn_id = cur_txn_id)
	    & lock_transaction_table.txn_id ^= ""b
         then
	  do;
	     there_is_an_active_transaction = YES;
	     call DISPLAY_TRANSACTION (lock_transaction_table_ptr);
	  end;
      end;

      if there_is_an_active_transaction = NO
      then
         do;
	  if transaction_selection = ALL_TRANSACTIONS
	  then call ioa_ ("There are no transactions holding locks.");
	  else if cur_txn_id ^= "0"b
	  then call ioa_ ("The current transaction does not hold any locks.");
	  else call ioa_ ("There is no current transaction for which to display locks.");
         end;

      call CLEANUP ();

MAIN_RETURN:
      return;
%page;
ABORT_ENTRY:
   procedure ();
      call CLEANUP ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;



CLEANUP:
   procedure ();
      if lm_copy_data_ptr ^= null ()
      then call release_temp_segments_ (myname, lm_copy_data.segment_ptrs, (0));

      call ssu_$release_area (sci_ptr, ssu_area_ptr);
      call ssu_$release_temp_segment (sci_ptr, temp_string_ptr);

      if this_is_a_standalone_invocation
      then call ssu_$destroy_invocation (sci_ptr);
      else ;

      lm_copy_data_ptr, lock_segments_ptr = null ();
   end CLEANUP;
%page;
PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

      dcl	    pa_p_arg	       char (*) parm;
      dcl	    pa_p_control_argument_idx
			       fixed bin parm;
      dcl	    pa_p_accept_control_argument
			       bit (1) aligned parm;

      dcl	    pa_code	       fixed bin (35);

      pa_code = 0;

      goto ARGUMENT (pa_p_control_argument_idx);
ARGUMENT (-1):
      call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The argument ""^a"" is out of place.", arg);
      return;
   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument, pca_p_force_interpretation_as_argument);


      dcl	    pca_p_arg	       char (*) parm;
      dcl	    pca_p_control_argument_idx
			       fixed bin parm;
      dcl	    pca_p_accept_control_argument
			       bit (1) aligned parm;
      dcl	    pca_p_force_interpretation_as_argument
			       bit (1) aligned parm;

      pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
      pca_p_accept_control_argument = YES;
      pca_p_force_interpretation_as_argument = NO;

      go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
      call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* -all_transactions */
CONTROL_ARGUMENT (2):				/* -atxn */
      transaction_selection = ALL_TRANSACTIONS;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;

CONTROL_ARGUMENT (3):				/* -current_transaction */
CONTROL_ARGUMENT (4):				/* -ctxn */
      transaction_selection = CURRENT_TRANSACTION;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (5):				/* -file_locks */
CONTROL_ARGUMENT (6):				/* -flk */
      display_file_locks = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (7):				/* -no_file_locks */
CONTROL_ARGUMENT (8):				/* -nflk */
      display_file_locks = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (9):				/* -control_interval_locks */
CONTROL_ARGUMENT (10):				/* -cilk */
      display_control_interval_locks = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (11):				/* -no_control_interval_locks */
CONTROL_ARGUMENT (12):				/* -ncilk */
      display_control_interval_locks = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (13):				/* -header */
CONTROL_ARGUMENT (14):				/* -he */
      display_header = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (15):				/* -no_header */
CONTROL_ARGUMENT (16):				/* -nhe */
      display_header = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (17):				/* -hash_table */
CONTROL_ARGUMENT (18):				/* -ht */
      display_hash_table = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (19):				/* -no_hash_table */
CONTROL_ARGUMENT (20):				/* -nht */
      display_hash_table = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


   end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

      dcl	    cai_p_arg	       char (*);
      dcl	    cai_control_argument_idx
			       fixed bin;

      do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	 while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
      end;
      if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
      then return (-1);
      else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;


REPORT_MISSING_ARGUMENT:
   proc (rma_p_control_argument_idx);
      dcl	    rma_p_control_argument_idx
			       fixed bin parm;

      call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	 CONTROL_ARGUMENT (rma_p_control_argument_idx),
	 (index ("aeiouh", substr (ARGUMENT_TYPE (rma_p_control_argument_idx), 1, 1)) > 0),
	 ARGUMENT_TYPE (rma_p_control_argument_idx));
   end REPORT_MISSING_ARGUMENT;
%page;
/*  Internal Procedure to display locks for one process  */

DISPLAY_TRANSACTION:
   proc (dt_p_lock_transaction_table_ptr);

      dcl	    dt_p_lock_transaction_table_ptr
			       ptr;

      dcl	    1 dt_process_vptr      aligned like lock_virtual_ptr;
      dcl	    dt_lock_owner_ptr      ptr;
      dcl	    dt_lock_waiter_ptr     ptr;

      dcl	    1 dt_lock_owner	       aligned like lock_owner based (dt_lock_owner_ptr);
      dcl	    1 dt_lock_transaction_table
			       aligned like lock_transaction_table based (dt_p_lock_transaction_table_ptr);
      dcl	    1 dt_lock_waiter       aligned like lock_waiter based (dt_lock_waiter_ptr);
      dcl	    1 dt_txi	       aligned like txn_info;

      dcl	    dt_indent	       fixed bin init (0);

      unspec (dt_txi) = ""b;
      dt_txi.version = TXN_INFO_VERSION_5;
      dt_txi.owner_name = "";
      call transaction_manager_$get_txn_info (dt_lock_transaction_table.txn_id, addr (dt_txi), code);
      call ioa_ ("^/^a ^w  Transaction ^d  ^[Ev Chan ^o^]", dt_txi.owner_name, dt_lock_transaction_table.process_id,
	 bin (dt_lock_transaction_table.txn_id, 71, 0), (dt_lock_transaction_table.ev_channel ^= 0),
	 dt_lock_transaction_table.ev_channel);

      dt_indent = 2;

      if dt_lock_transaction_table.wait_ptr.seg_inx ^= NULL_VPTR.seg_inx
      then
         do;
	  dt_lock_waiter_ptr = PTR (dt_lock_transaction_table.wait_ptr);
	  if dt_lock_waiter_ptr = null ()
	  then call REPORT_INVALID_VIRTUAL_POINTER (dt_indent, "Waiting", dt_lock_transaction_table.wait_ptr);
	  else
	     do;
	        call ioa_ ("^vxWaiting for ^a mode", dt_indent, LOCK_MODE_NAMES (dt_lock_waiter.mode));
	        call DISPLAY_LOCK (dt_indent, dt_lock_waiter.lock_ptr);
	     end;
         end;

      dt_indent = dt_indent + 2;

      dt_process_vptr = dt_lock_transaction_table.own_ptr;
      do while (dt_process_vptr.seg_inx ^= NULL_VPTR.seg_inx);
         dt_lock_owner_ptr = PTR (dt_process_vptr);
         if dt_lock_owner_ptr = null ()
         then
	  do;
	     call REPORT_INVALID_VIRTUAL_POINTER (dt_indent, "Owner", dt_process_vptr);
	     dt_process_vptr = NULL_VPTR;
	  end;
         else if dt_lock_owner.type ^= TYPE_OWNER
         then
	  do;
	     call ioa_ ("^vxInvalid Owner Type ^d at ^p", dt_indent, dt_lock_owner.type, dt_lock_owner_ptr);
	     dt_process_vptr = NULL_VPTR;
	  end;
         else
	  do;
	     call DISPLAY_LOCK (dt_indent, dt_lock_owner.lock_ptr);
	     dt_process_vptr = dt_lock_owner.transaction_fp;
	  end;
      end;

      call ioa_ ("");

   end DISPLAY_TRANSACTION;
%page;
/*  Internal Procedure to display a lock  */

DISPLAY_LOCK:
   proc (dl_p_indent, dl_p_lock_object_vptr);

      dcl	    1 dl_p_lock_object_vptr
			       aligned like lock_virtual_ptr parameter;
      dcl	    dl_p_indent	       fixed bin parm;

      dcl	    dl_indent	       fixed bin init (0);
      dcl	    dl_lock_object_ptr     ptr;
      dcl	    1 dl_lock_object       aligned like lock_object based (dl_lock_object_ptr);
      dcl	    1 dl_txi	       aligned like txn_info;


      dl_indent = dl_p_indent;

      dl_lock_object_ptr = PTR (dl_p_lock_object_vptr);
      if dl_lock_object_ptr = null ()
      then
         do;
	  call REPORT_INVALID_VIRTUAL_POINTER (dl_indent, "Object", dl_p_lock_object_vptr);
	  return;
         end;
      if dl_lock_object.type ^= TYPE_OBJECT
      then
         do;
	  call ioa_ ("^vxInvalid Object Type ^d at ^p", dl_indent, dl_lock_object.type, dl_lock_object_ptr);
	  return;
         end;

      if dl_lock_object.ci_no = FILE_LOCK_CI_NUMBER
      then if display_file_locks = NO
	 then return;
	 else ;
      else if display_control_interval_locks = NO
      then return;
      else ;


      call ioa_ ("^vxLock  UID=^w ^[FILE^s^;CI=^d^]", dl_indent, dl_lock_object.uid,
	 (dl_lock_object.ci_no = FILE_LOCK_CI_NUMBER), dl_lock_object.ci_no);

      dl_indent = dl_indent + 2;

      call DISPLAY_BLOCK_LIST (dl_lock_object.owners_ptr, dl_indent, "Owner", TYPE_OWNER, OWNER_GET_TXN_VPTR,
	 OWNER_GET_MODE, OWNER_GET_NEXT_BLOCK_VPTR);

      call DISPLAY_BLOCK_LIST (dl_lock_object.waiters_ptr, dl_indent, "Waiter", TYPE_WAITER, WAITER_GET_TXN_VPTR,
	 WAITER_GET_MODE, WAITER_GET_NEXT_BLOCK_VPTR);


   end DISPLAY_LOCK;
%page;
DISPLAY_BLOCK_LIST:
   proc (dbl_p_first_block_vptr, dbl_p_indent, dbl_p_str, dbl_p_type, dbl_p_get_txn_vptr, dbl_p_get_mode,
        dbl_p_get_next_block_vptr);
      dcl	    1 dbl_p_first_block_vptr
			       aligned like lock_virtual_ptr parm;
      dcl	    dbl_p_indent	       fixed bin parm;
      dcl	    dbl_p_str	       char (*) parm;
      dcl	    dbl_p_type	       fixed bin parm;
      dcl	    dbl_p_get_txn_vptr     variable entry (ptr) returns (1 aligned like lock_virtual_ptr) parm;
      dcl	    dbl_p_get_mode	       variable entry (ptr) returns (fixed bin) parm;
      dcl	    dbl_p_get_next_block_vptr
			       variable entry (ptr) returns (1 aligned like lock_virtual_ptr) parm;

      dcl	    dbl_indent	       fixed bin init (0);

      dcl	    1 dbl_lock_block_vptr  aligned like lock_virtual_ptr;
      dcl	    1 dbl_txi	       aligned like txn_info;
      dcl	    dbl_lock_block_ptr     ptr;
      dcl	    1 dbl_lock_block       aligned like lock_block based (dbl_lock_block_ptr);
      dcl	    1 dbl_lock_transaction_table_vptr
			       aligned like lock_virtual_ptr;
      dcl	    dbl_lock_transaction_table_ptr
			       ptr;
      dcl	    1 dbl_lock_transaction_table
			       aligned like lock_transaction_table based (dbl_lock_transaction_table_ptr);
      dcl	    dbl_code	       fixed bin (35) init (0);

      dbl_lock_block_vptr = dbl_p_first_block_vptr;
      dbl_indent = dbl_p_indent;

      dbl_txi.version = TXN_INFO_VERSION_5;
      dbl_txi.owner_name = "";

      do while (dbl_lock_block_vptr.seg_inx ^= NULL_VPTR.seg_inx);
         dbl_lock_block_ptr = PTR (dbl_lock_block_vptr);
         if dbl_lock_block_ptr = null ()
         then
	  do;
	     call REPORT_INVALID_VIRTUAL_POINTER (dbl_indent, dbl_p_str, dbl_lock_block_vptr);
	     dbl_lock_block_vptr = NULL_VPTR;
	  end;
         else if dbl_lock_block.type ^= dbl_p_type
         then
	  do;
	     call ioa_ ("^vxInvalid ^a Type ^d at ^p", dbl_p_str, dbl_indent, dbl_lock_block.type, dbl_lock_block_ptr);
	     dbl_lock_block_vptr = NULL_VPTR;
	  end;
         else
	  do;
	     dbl_lock_transaction_table_vptr = dbl_p_get_txn_vptr (dbl_lock_block_ptr);
	     dbl_lock_transaction_table_ptr = PTR (dbl_lock_transaction_table_vptr);
	     if dbl_lock_transaction_table_ptr = null ()
	     then call REPORT_INVALID_VIRTUAL_POINTER (dbl_indent, "Lock txn table", dbl_lock_transaction_table_vptr);
	     else
	        do;
		 call transaction_manager_$get_txn_info (dbl_lock_transaction_table.txn_id, addr (dbl_txi), dbl_code);
		 call ioa_ ("^vx^a ^a ^w Txn ^d ^45tMode ^3a", dbl_indent, dbl_p_str, dbl_txi.owner_name,
		      dbl_lock_transaction_table.process_id, bin (dbl_lock_transaction_table.txn_id, 71, 0),
		      LOCK_MODE_NAMES (dbl_p_get_mode (dbl_lock_block_ptr)));
		 dbl_lock_block_vptr = dbl_p_get_next_block_vptr (dbl_lock_block_ptr);
	        end;
	  end;
      end;
   end DISPLAY_BLOCK_LIST;
%page;
OWNER_GET_TXN_VPTR:
   proc (ogtv_p_lock_owner_ptr) returns (1 aligned like lock_virtual_ptr);
      dcl	    ogtv_p_lock_owner_ptr  ptr parm;
      dcl	    1 ogtv_p_lock_owner    aligned like lock_owner based (ogtv_p_lock_owner_ptr);

      return (ogtv_p_lock_owner.transaction_ptr);

OWNER_GET_MODE:
   entry (ogtv_p_lock_owner_ptr) returns (fixed bin);
      return (ogtv_p_lock_owner.mode);

OWNER_GET_NEXT_BLOCK_VPTR:
   entry (ogtv_p_lock_owner_ptr) returns (1 aligned like lock_virtual_ptr);
      return (ogtv_p_lock_owner.owners_fp);
   end OWNER_GET_TXN_VPTR;
%page;
WAITER_GET_TXN_VPTR:
   proc (wgtv_p_lock_waiter_ptr) returns (1 aligned like lock_virtual_ptr);
      dcl	    wgtv_p_lock_waiter_ptr ptr parm;
      dcl	    1 wgtv_p_lock_waiter   aligned like lock_waiter based (wgtv_p_lock_waiter_ptr);

      return (wgtv_p_lock_waiter.transaction_ptr);

WAITER_GET_MODE:
   entry (wgtv_p_lock_waiter_ptr) returns (fixed bin);
      return (wgtv_p_lock_waiter.mode);

WAITER_GET_NEXT_BLOCK_VPTR:
   entry (wgtv_p_lock_waiter_ptr) returns (1 aligned like lock_virtual_ptr);
      return (wgtv_p_lock_waiter.waiters_fp);
   end WAITER_GET_TXN_VPTR;
%page;
/*  Internal Procedure to turn a virtual pointer into a pointer  */

PTR:
   proc (ptr_p_lock_virtual_ptr) returns (ptr);

      dcl	    1 ptr_p_lock_virtual_ptr
			       aligned like lock_virtual_ptr parameter;


      if ptr_p_lock_virtual_ptr.seg_inx < 0 | ptr_p_lock_virtual_ptr.seg_inx > lm_copy_data_n_segments
      then return (null ());
      return (ptr (lock_segments.seg_baseptr (ptr_p_lock_virtual_ptr.seg_inx), ptr_p_lock_virtual_ptr.offset));

   end PTR;

GET_SEGMENT_PTRS:
   procedure ();
      dcl	    gs_code	       fixed bin (35) init (0);
      dcl	    gs_try_idx	       fixed bin;


      gs_code = error_table_$smallarg;
      do gs_try_idx = 1 to 10 while (gs_code = error_table_$smallarg);
         lm_copy_data_n_segments = lock_manager_$system_segment_count (gs_code);
         allocate lm_copy_data in (ssu_area);
         lm_copy_data.version = LM_COPY_DATA_VERSION_1;
         call get_temp_segments_ (myname, lm_copy_data.segment_ptrs, gs_code);
         if gs_code ^= 0
         then call ssu_$abort_line (sci_ptr, gs_code, "^/Unable to get temp segments to hold the copy of lock data.");
         call lock_manager_$copy_data (addr (lm_copy_data), gs_code);
         if gs_code ^= 0
         then
	  do;
	     call release_temp_segments_ (myname, lm_copy_data.segment_ptrs, (0));
	     free lm_copy_data;
	  end;
      end;
      if gs_code ^= 0
      then call ssu_$abort_line (sci_ptr, gs_code, "^/Unable to copy the lock data.");

      lock_seg_ptr = lm_copy_data.segment_ptrs (1);
      call CHECK_VERSION (LOCK_SEG_VERSION_1, lock_seg.version, "lock_seg");
      allocate lock_segments in (ssu_area);
      lock_segments.seg_baseptr (*) = lm_copy_data.segment_ptrs (*);
      return;

   end GET_SEGMENT_PTRS;



CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_received_version, cv_p_structure_name);

      dcl	    cv_p_expected_version  char (8) aligned parameter;
      dcl	    cv_p_received_version  char (8) aligned parameter;
      dcl	    cv_p_structure_name    char (32) aligned parameter;

      if cv_p_expected_version ^= cv_p_received_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null (), 0,
	      "^/Expected version ^a of the ^a structure." || "^/Received version ^a instead.", cv_p_expected_version,
	      cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;
%page;
REPORT_INVALID_VIRTUAL_POINTER:
   proc (rivp_p_indent, rivp_p_str, rivp_p_virtual_ptr);
      dcl	    rivp_p_indent	       fixed bin parm;
      dcl	    rivp_p_str	       char (*) parm;
      dcl	    1 rivp_p_virtual_ptr   aligned like lock_virtual_ptr parm;

      call ioa_ ("^vx^a - invalid virtual pointer (segment index ^d, offset ^d).", rivp_p_indent, rivp_p_str,
	 rivp_p_virtual_ptr.seg_inx, rivp_p_virtual_ptr.offset);

   end REPORT_INVALID_VIRTUAL_POINTER;
%page;
%include dm_lock_modes;
%page;
%include dm_lm_meters;
%page;
%include dm_lm_system_data;
%page;
%include dm_lm_copy_data;
%page;
%include dm_tm_txn_info;
%page;
%include print_data_info;
%page;
%include sub_err_flags;
   end dm_lock_status;




		    dm_log_.pl1                     03/15/89  0845.1r w 03/15/89  0800.6      123867



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




/****^  HISTORY COMMENTS:
  1) change(86-10-17,Dupuis), approve(86-11-06,MCR7566), audit(86-11-07,Blair),
     install(86-11-10,MR12.0-1207):
     Initialized the parent_ac_sw in auto_create_branch_info to "1"b so that it
     would create the "logs" directory at the same AIM level as its containing
     directory (phx20619).
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

     Primitive interface to the data management log, to be used by all
processes that need to leave a message in an accessable place for future
use.  This procedure contains a locking protocol for the data management
system log.

     There are two entries to this program.  The first is dm_log_, which
uses a "long" calling sequence.  That is, the user provides all
information for logging in the dm_log_ call.  The other is
dm_log_$from_arg_ptr, a pass through method.  The caller must provide an
argument list pointer a the only argument.  Any error taken while trying
to log will be swallowed by the any_other handler and not reported to the
user.  Record quota overflows and segment faults are tried to be reported
in the log, but these may be lost.  Normally, this should not be a
problem.

     The "find" entrypoint has been added to initiate the log during boot
time, following a requirement that the log must be able to be referenced
before data management commences.

     Two calling sequences are recognized by dm_log_, one for error
reporting and one for simple reporting.  Error reports will generate two
entries in the log, simple reports will generate one entry.  The calling
sequences are:

	call dm_log_ (severity, code, caller, ioa_ctl_string,
					ioa_arg1, ..., ioa_argN);
	call dm_log_ (severity, ioa_ctl_string, ioa_arg1, ..., ioa_argN);

   the fundamental flow of this program is:

	DM_LOG_

	     MAKE_MESSAGE

	     LOCK_LOG
	     if   CANNOT_LOCK_LOG then
	     else do
		WRITE_INTO_LOG (time, severity, id || message)
		UNLOCK_LOG
		end

        end DM_LOG_
*/

/* HISTORY:

Written by M. Pandolf, 01/11/83.
Modified:
02/01/83 by M. Pandolf: to accept pointer to arg list in addition
	  to accepting an arglist directly.
05/05/83 by B. Margulies: to stop using write_log_, stop truncating messages.
06/27/83 by L. A. Newcomb:  Fixed minor problem with long continuation msgs
            wrapping because of tab at start of extra lines, multiple names
            on old log segments; deleted obs. entry set_dir.
08/08/83 by L. A. Newcomb:  checked to call term_$refname if we are using the
            installed dm_system_data_.  If we don't, the Daemon may use the
            wrong sys data in the takeover checking.
08/14/83 by L. A. Newcomb:  fixed to use decode_descriptor_ instead of looking
            at the argument list directly; now handles a varying string for
            the caller as well as non-varying.
09/19/83 by L. A. Newcomb:  moved dm_data_$sys_log_ptr to int. static and 
	  changed any_other handler to cleanup handler only.
10/13/83 by M. Pandolf:  added "find" entrypoint.
03/05/84 by L. A. Newcomb:  changed to use the include file dm_system_states
            (renamed from dm_statuses), and to use the new names therein.
08/20/84 by Matthew Pierret:  Changed processing of varying character strings 
            the argument list to take into account the fact that 
            arg_list.arg_ptrs points at the string, not the length word.
11/22/84 by Lee A. Newcomb:  Changed to use dm_misc_util_$get_aim_dir.
12/05/84 by R. Michael Tague:  Since above $get_aim_dir doesn't return a code,
            I took out the code check in open_log.
01/08/85 by Steve Herbst: Converted to call log_write_ and not reference dm_system_data_.
02/07/85 by Steve Herbst: Changed to call dm_misc_util_$get_log_path instead of $get_aim_dir.
02/19/85 by Steve Herbst: Changed to create the directory AIM_DIR>logs.
*/
/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */
%page;
dm_log_:
     procedure () options (variable);


/* DECLARATIONS */

/* Parameters */

dcl A_arglist_ptr ptr;

/* Constants */

dcl CREATE_IF_NONE bit (1) aligned int static options (constant) init ("1"b);
dcl FIFTEEN_SECOND_WAIT fixed bin int static options (constant) init (15);

/* Static */

dcl static_log_write_data_ptr ptr int static init (null);

/* Automatic */

dcl 1 auto_create_branch_info aligned like create_branch_info;

dcl 1 log_acl aligned like segment_acl_entry;
dcl log_ring_brackets (3) fixed bin (3);

dcl (message, message1, message2) char (1024);
dcl (dm_system_log_path, log_dir_dname, log_dname) char (168);
dcl long_report char (100) aligned;
dcl (acct, log_dir_ename, log_ename, my_name) char (32);
dcl person_id char (22);
dcl project_id char (9);
dcl short_report char (8) aligned;
dcl arg_packed bit (1) aligned;
dcl arglist_ptr ptr;
dcl type fixed bin (2);
dcl (arg_ndims, arg_scale, arg_type, message_severity) fixed bin;
dcl message_len fixed bin (21);
dcl (arg_size, bit_count) fixed bin (24);
dcl (code, error_code) fixed bin (35);

/* External */

dcl error_table_$no_s_permission fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;

/* Entries */

dcl convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl cu_$arg_list_ptr entry (ptr);
dcl cu_$level_get entry (fixed bin);
dcl cu_$level_set entry (fixed bin);
dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin, fixed bin(24), fixed bin);
dcl dm_misc_util_$get_log_path entry (char (*));
dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl get_ring_ entry() returns(fixed bin(3));
dcl hcs_$add_acl_entries entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
dcl hcs_$create_branch_ entry (char(*), char(*), ptr, fixed bin(35));
dcl hcs_$set_ring_brackets entry (char(*), char(*), (3)fixed bin(3), fixed bin(35));
dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char(*), fixed bin(21), bit(1) aligned, bit(1) aligned);
dcl ioa_$rsnnl entry() options(variable);
dcl log_write_$message entry (ptr, fixed bin, char(*), ptr, fixed bin(35));
dcl log_write_$open entry (char(*), char(*), bit(1) aligned, ptr, fixed bin(35));
dcl pathname_ entry (char (*), char (*)) returns (char (168));
dcl user_info_$whoami entry (char(*), char(*), char(*));

/* Builtins */

dcl (addr, addwordno, null, substr, unspec) builtin;

/* Conditions */

dcl (cleanup, record_quota_overflow, seg_fault_error) condition;
%page;
/* dm_log_:  proc () options (variable) */

	my_name = "dm_log_";
	call cu_$arg_list_ptr (arglist_ptr);
	go to COMMON;


from_arg_ptr:					/* entrypoint to accept arglist_ptr as an argument */
     entry (A_arglist_ptr);

	my_name = "dm_log_$from_arg_ptr";
	arglist_ptr = A_arglist_ptr;
	go to COMMON;

COMMON:
	if arglist_ptr -> arg_list.arg_count < 2 then return;

/* Open/create the log if necessary */

	if static_log_write_data_ptr = null then do;
	     call dm_misc_util_$get_log_path (dm_system_log_path);
	     call expand_pathname_ (dm_system_log_path, log_dname, log_ename, 0);
	     call hcs_$status_minf (log_dname, "", 0, type, bit_count, code);  /* make sure log dir exists */
	     if code = 0 | code = error_table_$no_s_permission then do;  /* something by that name exists */
		if type ^= 2 /* directory */ | bit_count ^= 0 then
		     call ERROR_RETURN (0, "Not a directory: " || log_dname);
	     end;
	     else if code = error_table_$noentry then do;	/* create it */
		unspec (auto_create_branch_info) = "0"b;
		auto_create_branch_info.version = create_branch_version_2;
		auto_create_branch_info.dir_sw = "1"b;
		auto_create_branch_info.parent_ac_sw = "1"b;
		auto_create_branch_info.mode = SMA_ACCESS;
		auto_create_branch_info.rings (*) = get_ring_ ();
		auto_create_branch_info.userid = "*.*.*";  /* all users need access to this dir in ring 2 */
		call expand_pathname_ (log_dname, log_dir_dname, log_dir_ename, code);
		if code ^= 0 then call ERROR_RETURN (code, "Unable to create log directory " || log_dname);
		call hcs_$create_branch_ (log_dir_dname, log_dir_ename, addr (auto_create_branch_info), code);
		if code ^= 0 then call ERROR_RETURN (code, "Unable to create log directory " || log_dname);
	     end;
	     else call ERROR_RETURN (code, "Log directory " || log_dname);

	     call log_write_$open (log_dname, log_ename, CREATE_IF_NONE, static_log_write_data_ptr, code);
	     if code ^= 0 then call ERROR_RETURN (code, "Cannot open log " || pathname_ (log_dname, log_ename));

/* If had to open, add ACL entry "rw *.*.*" */

	     unspec (log_acl) = "0"b;
	     log_acl.access_name = "*.*.*";
	     log_acl.mode = RW_ACCESS;
	     call hcs_$add_acl_entries (log_dname, log_ename, addr (log_acl), 1, 0);

	     log_ring_brackets (*) = get_ring_ ();
	     call hcs_$set_ring_brackets (log_dname, log_ename, log_ring_brackets, 0);
	end;

/* Get some values needed for the message */

	call user_info_$whoami (person_id, project_id, acct);
	message_severity = FIXED_BIN_17 (1);
	message1, message2 = "";

/* Decide what type of call this is. Error call if parameter 2 is fixed bin(35) */

	call decode_descriptor_ (arglist_ptr, 2, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);
	if arg_type = real_fix_bin_1_dtype & arg_packed = "0"b & arg_ndims = 0 & arg_scale = 0 then do;

/* Error call */

	     error_code = FIXED_BIN_35 (2);		/* from parm 2 */
	     if error_code = 0 then short_report, long_report = "";
	     else call convert_status_code_ (error_code, short_report, long_report);
	     call ioa_$rsnnl ("(^a.^a) ^a: ^a", message1, message_len, person_id, project_id, CHAR_N (3), long_report);

	     if arglist_ptr -> arg_list.arg_count > 3 then do;
		call ioa_$general_rs (arglist_ptr, 4, 5, message2, message_len, "0"b, "0"b);
		call ioa_$rsnnl ("^a^/^a", message, message_len, message1, message2);
	     end;
	     else message = message1;
	end;

	else do;

/* Not error call */

	     call ioa_$general_rs (arglist_ptr, 2, 3, message1, 0, "0"b, "0"b);
	     call ioa_$rsnnl ("(^a.^a) ^a", message, message_len, person_id, project_id, message1);
	end;

	call WRITE_MESSAGE (substr (message, 1, message_len), message_severity);

RETURN:
	return;
%page;
ERROR_RETURN:
     procedure (P_code, P_str);

dcl P_code fixed bin (35);
dcl P_str char (*);

	/* Code and message are temporarily thrown away until a good way is
	   found to report them. */

	go to RETURN;

end ERROR_RETURN;
%page;
FIXED_BIN_17:
     procedure (P_arg_number) returns (fixed bin (17));

dcl P_arg_number fixed bin;
dcl fb17 fixed bin based;

	if arglist_ptr -> arg_list.arg_count >= P_arg_number then
	     return (arglist_ptr -> arg_list.arg_ptrs (P_arg_number) -> fb17);
	else return (0);

end FIXED_BIN_17;
%page;
FIXED_BIN_35:
     procedure (P_arg_number) returns (fixed bin (35));

dcl P_arg_number fixed bin;
dcl fb35 fixed bin (35) based;

	if arglist_ptr -> arg_list.arg_count >= P_arg_number then
	     return (arglist_ptr -> arg_list.arg_ptrs (P_arg_number) -> fb35);
	else return (0);

end FIXED_BIN_35;
%page;
CHAR_N:
     procedure (P_arg_number) returns (char (*));

dcl P_arg_number fixed bin;
dcl char_non_varying char (1000000) based;
dcl char_varying char (1000000) varying based;
dcl char_varying_ptr ptr;

	call decode_descriptor_ (arglist_ptr, P_arg_number, arg_type, arg_packed, arg_ndims, arg_size, arg_scale);
	if arg_type < 1 then return ("");		/* no desc. or no arg. in the given position */
	if arg_packed = "1"b | arg_ndims ^= 0 | arg_scale ^= 0 | arg_size < 1 then return ("");

	if arg_type = char_dtype then			/* non-varying, assumed most common case */
	     return (substr (arglist_ptr -> arg_list.arg_ptrs (P_arg_number) -> char_non_varying, 1, arg_size));
	if arg_type = varying_char_dtype then do;	/* can still do it */
						/* PL/1 kludge has arg_list pointer point at data, */
						/* not length word, so back it up. */
	     char_varying_ptr = addwordno (arglist_ptr -> arg_list.arg_ptrs (P_arg_number), -1);
	     return (char_varying_ptr -> char_varying);	/* do not need substr */
	end;
	else return ("");				/* if we got here, we had a non-char type */

end CHAR_N;
%page;
WRITE_MESSAGE:
     procedure (P_message, P_message_severity);		/*  Writes a message to the log */

dcl P_message char (*);
dcl P_message_severity fixed bin;
dcl saved_validation fixed bin;

	call cu_$level_get (saved_validation);
	on cleanup begin;
	     call cu_$level_set (saved_validation);
	end;
	call cu_$level_set (get_ring_ ());

	on record_quota_overflow, seg_fault_error begin;
	     on record_quota_overflow, seg_fault_error goto PUNT_WARNING;
	     call log_write_$message (static_log_write_data_ptr, 2,
		"*** MESSAGES HAVE BEEN LOST ***", null, 0);
PUNT_WARNING:
	     call cu_$level_set (saved_validation);
	     go to RETURN;
	end;

	call log_write_$message (static_log_write_data_ptr, P_message_severity, P_message, null, code);
	if code ^= 0 then call ERROR_RETURN (code, "");

	revert record_quota_overflow, seg_fault_error;

	call cu_$level_set (saved_validation);

end WRITE_MESSAGE;
%page; %include access_mode_values;
%page; %include acl_structures;
%page; %include arg_list;
%page; %include arg_descriptor;
%page; %include create_branch_info;
%page; %include dm_system_states;
%page; %include std_descriptor_types;
%page; %include sub_err_flags;
%page; %include terminate_file;

end dm_log_;




		    dm_log_read_.alm                03/06/85  0759.4re  03/05/85  0755.9        6129



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************
	" dm_log_read_.alm -- transfer vector to the log reading gates
	" Modification history:
	" Created 1984-12-12, BIM.

	macro	tv
	segdef	&1
&1:	getlp
	call6	dm_admin_gate_$dlr_&1
&end

	tv	open
	tv	close
	tv	get_log_uid
	tv	hold_message
	tv	free_message
	tv	next_message
	tv	prev_message
	tv	position_sequence
	tv	position_time
	tv	register
	tv	deregister
	tv	update
	end




		    dm_log_read_inner_.pl1          04/04/85  1114.9re  04/04/85  0824.8      117477



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc */
/* --------------- */

dm_log_read_inner_: procedure;

/* DESCRIPTION:

   This procedure contains entry points with the same calling sequences
   as log_read_, but used instead to read ring-2 DM log segments.
*/

/* HISTORY:

   Written by Steve Herbst, 11/30/84
   Modified:
   12/06/84 by Steve Herbst: Added $get_log_uid, $free_message, $register, and $deregister.
   1984-12-12, BIM: corrected open calling sequence.
   1985-01-11, Steve Herbst: Alphabetized internal procedures.
   1985-02-07, Steve Herbst: Changed to call dm_misc_util_$get_log_path instead of $get_aim_dir.
   1985-03-07, Steve Herbst: Changed in response to audit. Replaced FINISHED
	and FINISHED_NO_CODE procs with ERROR_RETURN proc and RETURN label;
	changed to compare log uid's not pathnames.
   1985-03-11, Steve Herbst: Fixed $(next prev)_message to make a real
	inner-ring copy of P_log_message_ptr to pass to log_read_.
   1985-03-13, Steve Herbst: Fixed $update, $(hold free)_message to do same.
   1985-03-20, Steve Herbst: Fixed to allow up to 10 openings of the DM log per process.
*/


/* DECLARATIONS */

/* Parameters */

dcl  P_log_dname char (*);
dcl  P_log_ename char (*);
dcl  P_area_ptr ptr;
dcl  P_log_read_data_ptr ptr;
dcl  P_log_message_ptr ptr;
dcl  P_message_sequence fixed bin (35);
dcl  P_message_time fixed bin (71);
dcl  P_event_channel fixed bin (71);
dcl  P_search_direction bit (1) aligned;
dcl  P_log_uid bit (36) aligned;
dcl  P_process_id bit (36) aligned;
dcl  P_code fixed bin (35);


/* Constants */

dcl ME char (32) int static options (constant) init ("dm_log_read_inner_");

/* Static */

dcl static_log_read_ptr (10) ptr int static init ((10)null);

/* Automatic */

dcl 1 auto_status_branch aligned like status_branch;

dcl  log_dname char (168);
dcl  log_ename char (32);
dcl  log_read_data_ptr pointer;
dcl  log_message_ptr pointer;
dcl  search_direction bit (1) aligned;
dcl  opening_index fixed bin;
dcl  message_sequence fixed bin (35);
dcl  message_time fixed bin (71);
dcl  process_id bit (36) aligned;
dcl  event_channel fixed bin (71);
dcl  (log_uid, true_uid) bit (36) aligned;
dcl  area_ptr ptr;
dcl  code fixed bin (35);
dcl  (dm_system_log_path, true_dir_name) char (168);
dcl  true_entryname char (32);
dcl  saved_validation fixed bin (3);

dcl  1 log_open_info aligned like log_read_open_info;

/* External */

dcl  error_table_$badcall fixed bin (35) ext;
dcl  error_table_$not_closed fixed bin (35) ext static;
dcl  error_table_$not_open fixed bin (35) ext static;
dcl  error_table_$not_seg_type fixed bin (35) ext static;
dcl  error_table_$null_info_ptr fixed bin (35) ext static;
dcl  error_table_$out_of_sequence fixed bin (35) ext;

/* Entries */

declare  cu_$level_get entry returns (fixed bin (3));
declare  cu_$level_set entry (fixed bin (3));
declare  expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
declare  get_ring_ entry () returns (fixed bin (3));
declare  dm_misc_util_$get_log_path entry (char (*));
declare  hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
declare  log_read_$open_long entry (character (*), character (*), pointer, pointer, fixed binary (35));
declare  log_read_$close entry (pointer, fixed binary (35));
declare  log_read_$position_time entry (pointer, fixed binary (71), bit (1) aligned, pointer, fixed binary (35));
declare  log_read_$position_sequence entry (pointer, fixed binary (35), bit (1) aligned, pointer,
	    fixed binary (35));
declare  log_read_$next_message entry (pointer, pointer, fixed binary (35));
declare  log_read_$prev_message entry (pointer, pointer, fixed binary (35));
declare  log_read_$get_log_uid entry (pointer, bit (36) aligned, fixed binary (35));
declare  log_read_$update entry (fixed binary (35), pointer, pointer, fixed binary (35));
declare  log_read_$register entry (pointer, bit (36) aligned, fixed binary (71), fixed binary (35));
declare  log_read_$deregister entry (pointer, bit (36) aligned, fixed binary (71), fixed binary (35));
declare  log_read_$hold_message entry (pointer, pointer);
declare  log_read_$free_message entry (pointer, pointer);
declare  sub_err_ entry() options(variable);

/* Builtins */

dcl  (addr, baseno, baseptr, hbound, null, pointer, rel) builtin;

/* Conditions */

dcl  cleanup condition;

/* END OF DECLARATIONS */
%page;
dm_log_read_inner_$open:
     entry (P_log_dname, P_log_ename, P_area_ptr, P_log_read_data_ptr, P_code);

/* Opens a log for reading */

	log_dname = P_log_dname;
	log_ename = P_log_ename;
	area_ptr = P_area_ptr;
	P_log_read_data_ptr = null;
	code = 0;

	saved_validation = -1;
	on cleanup call CLEAN_UP;
	saved_validation = cu_$level_get ();

	do opening_index = 1 to hbound (static_log_read_ptr, 1)
	     while (static_log_read_ptr (opening_index) ^= null);
	end;
	if opening_index > hbound (static_log_read_ptr, 1) then
	     call sub_err_ (error_table_$not_closed, ME, ACTION_CANT_RESTART, null, 0,
		"The DM system log can only be opened ^d times per process.", hbound (static_log_read_ptr, 1));

	call cu_$level_set (get_ring_ ());

	call dm_misc_util_$get_log_path (dm_system_log_path);
	call expand_pathname_ (dm_system_log_path, true_dir_name, true_entryname, 0);
	call hcs_$status_long (true_dir_name, true_entryname, 0, addr (auto_status_branch), null, 0);
	true_uid = auto_status_branch.uid;
	call hcs_$status_long (log_dname, log_ename, 0, addr (auto_status_branch), null, 0);
	if auto_status_branch.uid ^= true_uid
	then call ERROR_RETURN (error_table_$not_seg_type);
					/* Only permit opens of the current DM system log for now */

	if area_ptr = null ()
	then call ERROR_RETURN (error_table_$null_info_ptr);

	log_open_info.version = LOG_READ_OPEN_INFO_VERSION_1;
	log_open_info.reader_procedure = "";
	log_open_info.allocation_area_ptr = area_ptr;
	log_open_info.allocate_copies = "1"b;

	call log_read_$open_long (log_dname, log_ename, addr (log_open_info),
	     static_log_read_ptr (opening_index), code);
	if code = 0 then P_log_read_data_ptr = static_log_read_ptr (opening_index);
	P_code = code;
RETURN:
	call CLEAN_UP;

	return;
%page;
dm_log_read_inner_$close:
     entry (P_log_read_data_ptr, P_code);

/* Closes a log */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	call log_read_$close (log_read_data_ptr, code);
	if code = 0 then static_log_read_ptr (opening_index) = null;
	else call ERROR_RETURN (code);

	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$next_message:
     entry (P_log_read_data_ptr, P_log_message_ptr, P_code);

/* Positions to the next message after P_log_message_ptr */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	log_message_ptr = INNER_RING_POINTER (P_log_message_ptr);
						/* OK to do this because log_read_ validates the ptr */

	call log_read_$next_message (log_read_data_ptr, log_message_ptr, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_log_message_ptr = log_message_ptr;
	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$prev_message:
     entry (P_log_read_data_ptr, P_log_message_ptr, P_code);

/* Positions to the message previous to P_log_message_ptr */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	log_message_ptr = INNER_RING_POINTER (P_log_message_ptr);
						/* OK to do this because log_read_ validates the ptr */

	call log_read_$prev_message (log_read_data_ptr, log_message_ptr, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_log_message_ptr = log_message_ptr;
	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$position_sequence:
     entry (P_log_read_data_ptr, P_message_sequence, P_search_direction, P_log_message_ptr, P_code);

/* Positions to the first/last message in sequence */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	message_sequence = P_message_sequence;
	search_direction = P_search_direction;

	call log_read_$position_sequence (log_read_data_ptr, message_sequence,
	     search_direction, log_message_ptr, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_log_message_ptr = log_message_ptr;
	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$position_time:
     entry (P_log_read_data_ptr, P_message_time, P_search_direction, P_log_message_ptr, P_code);

/* Positions to the first/last message before/after a specified time */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	message_time = P_message_time;
	search_direction = P_search_direction;

	call log_read_$position_time (log_read_data_ptr, message_time,
	     search_direction, log_message_ptr, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_log_message_ptr = log_message_ptr;
	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$update:
     entry (P_message_sequence, P_log_read_data_ptr, P_log_message_ptr, P_code);

/* Interface to log_read_$update */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	message_sequence = P_message_sequence;
	log_message_ptr = INNER_RING_POINTER (P_log_message_ptr);
						/* OK to do this because log_read_ validates the ptr */

	call log_read_$update (message_sequence, log_read_data_ptr, log_message_ptr, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_log_read_data_ptr, static_log_read_ptr (opening_index) = log_read_data_ptr;
	P_log_message_ptr = log_message_ptr;
	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$hold_message:
     entry (P_log_read_data_ptr, P_log_message_ptr);

/* Saves message so that it can be referenced by a call to $prev_message or $next_message */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	log_message_ptr = INNER_RING_POINTER (P_log_message_ptr);
						/* OK to do this because log_read_ validates the ptr */

	call log_read_$hold_message (log_read_data_ptr, log_message_ptr);
	go to RETURN;
%page;
dm_log_read_inner_$free_message:
     entry (P_log_read_data_ptr, P_log_message_ptr);

/* Frees message held by $hold_message */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	log_message_ptr = INNER_RING_POINTER (P_log_message_ptr);
						/* OK to do this because log_read_ validates the ptr */

	call log_read_$free_message (log_read_data_ptr, log_message_ptr);
	go to RETURN;
%page;
dm_log_read_inner_$get_log_uid:
     entry (P_log_read_data_ptr, P_log_uid, P_code);

/* Returns the uid of the log segment */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	call log_read_$get_log_uid (log_read_data_ptr, log_uid, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_log_uid = log_uid;
	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$register:
     entry (P_log_read_data_ptr, P_process_id, P_event_channel, P_code);

/* Interface to log_read_$register */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	process_id = P_process_id;
	event_channel = P_event_channel;

	call log_read_$register (log_read_data_ptr, process_id, event_channel, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_code = 0;
	go to RETURN;
%page;
dm_log_read_inner_$deregister:
     entry (P_log_read_data_ptr, P_process_id, P_event_channel, P_code);

/* Interface to log_read_$deregister */

	saved_validation = -1;
	on cleanup call CLEAN_UP;

	call VALIDATE ();

	process_id = P_process_id;
	event_channel = P_event_channel;

	call log_read_$deregister (log_read_data_ptr, process_id, event_channel, code);
	if code ^= 0 then call ERROR_RETURN (code);

	P_code = 0;
	go to RETURN;
%page;
CLEAN_UP: proc;

	if saved_validation ^= -1 then
	     call cu_$level_set (saved_validation);

end CLEAN_UP;
%page;
ERROR_RETURN: proc (P_local_code);

dcl P_local_code fixed bin (35);

	P_code = P_local_code;
	go to RETURN;

end ERROR_RETURN;
%page;
INNER_RING_POINTER: proc (P_ptr) returns (ptr);

dcl (P_ptr, inner_ring_ptr) ptr;
dcl (offset, segno) bit (18);

	segno = baseno (P_ptr);
	offset = rel (P_ptr);
	inner_ring_ptr = pointer (baseptr (segno), offset);
	return (inner_ring_ptr);

end INNER_RING_POINTER;
%page;
VALIDATE:
     procedure;

	log_read_data_ptr = P_log_read_data_ptr;

	do opening_index = 1 to hbound (static_log_read_ptr, 1)
	     while (static_log_read_ptr (opening_index) ^= log_read_data_ptr);
	end;
	if opening_index > hbound (static_log_read_ptr, 1) then
	     call sub_err_ (error_table_$not_open, ME, ACTION_CANT_RESTART, null, 0,
		"Invalid log_read_data_ptr ^p.", log_read_data_ptr);

	saved_validation = cu_$level_get ();
	call cu_$level_set (get_ring_ ());

	log_read_data_ptr = static_log_read_ptr (opening_index);  /* take inner ring copy */

	return;

end VALIDATE;
%page;
%include log_read_open_info;
%page;
%include status_structures;
%page;
%include sub_err_flags;


end dm_log_read_inner_;




		    dm_misc_util_.alm               04/24/85  1016.3re  04/24/85  0803.0       39555



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
" 	This is the main transfer vector for the miscellaneous Data
"    Management primitives.
"
" HISTORY:
" Written by R. Michael Tague, 07/17/84.
" Modified:
" 07/22/84 by R.Michael Tague:  Added dm_user_shut_handler_,
"	    dm_shut_warn_handler_
" 08/02/84 by Lee A. Newcomb:  added entries $get_system_state,
"	    $get_user_shutdown_time, and $get_shutdown_reason.
" 09/26/84 by Lindsey Spratt: Added the copy_dm_log entry. Alphabetized the
"	    entries. Added dm_real_copy_log.  Fixed all entries to be fully
"	    specified: foo$foo instead of just foo.  Changed from having
"	    just a transfer macro to using either simple_transfer or
"	    gate_transfer.  Now, call6, which was used by the transfer
"	    macro, is only done for gate transfers.  A simple tra is used
"	    for non-gate transfers.
" 10/01/84 by Lee A. Newcomb: changed dm_(user_shut shut_warn)_handler_'s to
"	    signal_(user_shutdown shutdown_warning), added shutdown_handler,
"	    get_(begin_shutdown shutdown_warning)_time, and
"	    set_system_dir (so users can use a test DMS).
" 10/29/84 by Lee A. Newcomb:  Fixed to remove any dm_ prefixes from entries.
" 11/12/84 by Lindsey Spratt:  Added the $set_journal_stamps entry.
" 11/19/84 by Lee A. Newcomb:  Changed $get_*_dir to go through dm_gate_.
" 11/28/84 by Stanford S. Cox: Added get_(aim_dir, initialization_time), 
"	    removed get_system_data.
" 12/07/84 by Lindsey Spratt:  Changed get_initialization_time to go to
"	    dm_gate_$dm_get_init=, $is_process_using_dm to go to
"	    dm_gate_$dm_using_dm.
" 12/07/84 by R. Michael Tague:  Added $dm_status, $find_old_boot_dir, and
"	    $terminate_dm.
" 12/08/84 by Lindsey Spratt:  Fixed $dm_status and $find_old_boot_dir to tra
"	    to dm_firstref_tv_$= instead of dm_firstref_util_$=, which is
"	    not externally retained.
" 12/10/84 by Lindsey Spratt:  Added the $open_log entry.  Fixed
"	    $get_initialization_time and $is_process_using_dm to use
"	    gate_transfer instead of simple_transfer.
" 01/25/84 by Lindsey Spratt:  Added $get_system_version.
" 02/07/85 by Steve Herbst: Added $get_log_path.
" 03/05/85 by Steve Herbst: Added $log, ultimate target dm_log_.
" 03/11/85 by Lindsey Spratt:  Removed $open_log (dm_log_util_ is obsolete).
" 04/10/85 by Lee A. Newcomb:  Removed the obsolete entries $copy_dm_log
"             and $real_copy_dm_log. Removed $set_journal_stamps as it is
"             in dm_admin_util_.
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
     
	name	dm_misc_util_

	macro	gate_transfer
	entry	&1
&1:
	call6	&2

	&end
	macro	simple_transfer
	entry	&1
&1:
	tra	&2
	&end

	simple_transfer     dm_status,dm_firstref_tv_$dm_status
	simple_transfer     find_old_boot_dir,dm_firstref_tv_$find_old_boot_dir
	simple_transfer	get_log_path,dm_no_firstref_util_$get_log_path
	simple_transfer	log,dm_no_firstref_tv_$log
	gate_transfer	get_aim_dir,dm_gate_$dm_get_aim_dir
	gate_transfer	get_begin_shutdown_time,dm_gate_$dm_get_begin_shutdown_time
	gate_transfer	get_bootload_dir,dm_gate_$dm_get_bootload_dir
	gate_transfer	get_enabled_bootload_dirname,dm_gate_$dm_get_enabled_boot_dirname
	gate_transfer	get_initialization_time,dm_gate_$dm_get_initialization_time
	gate_transfer	get_shutdown_reason,dm_gate_$dm_get_shutdown_reason
	gate_transfer	get_shutdown_warning_time,dm_gate_$dm_get_shutdown_warning_time
	gate_transfer	get_system_dir,dm_gate_$dm_get_system_dir
	gate_transfer	get_system_state,dm_gate_$dm_get_system_state
	gate_transfer	get_system_version,dm_gate_$dm_get_system_version
	gate_transfer	get_user_shutdown_time,dm_gate_$dm_get_user_shutdown_time
	gate_transfer	is_process_using_dm,dm_gate_$dm_is_process_using_dm
	gate_transfer	set_system_dir,dm_gate_$dm_set_system_dir
	simple_transfer	shutdown_handler,dm_shutdown_handler$dm_shutdown_handler
	simple_transfer	signal_shutdown_warning,dm_signal_shutdown_warning$dm_signal_shutdown_warning
	simple_transfer	signal_user_shutdown,dm_signal_user_shutdown$dm_signal_user_shutdown
	simple_transfer     terminate_dm,dm_no_firstref_util_$terminate_dm

	
	end




		    dm_no_firstref_tv_.alm          04/24/85  1016.3re  04/24/85  0803.0       28917



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
"
"	This is the inner-ring transfer vector for miscellaneous Data
"    Management primitives which must not let per-process initialization
"    be executed.  Primitives which do require the execution  of per-process 
"    initialization are channelled through dm_firstref_tv_, which has a
"    first-reference trap which executes per-process initialization.
"
"
" HISTORY:
"
" Written by Matthew Pierret, 09/17/84.
" Modified:
" 10/03/84 by Lee A. Newcomb:  Added $create_aim_control_seg and $set_aim_dir.
" 11/22/84 by Lee A. Newcomb:  Added entries to get various DM directory
"	    information, set the system directory, and deleted the entries
"	    $create_aim_control_seg and $set_aim_dir.
" 12/03/84 by Stanford S. Cox: Renamed dm_no_firstref_tv_, added find_log,
"	    copy_log, initialize_system, log_message, set_system_state,
"	    is_process_using_dm, get_system_state, using_dm.
" 12/09/84 by Lindsey Spratt: Moved dm_log_ to dm_firstref_tv_.
" 12/10/84 by Lindsey Spratt: Moved $find_log back.
" 12/18/84 by Steve Herbst: Added DM log-reading entry points dlr_open, etc.
" 03/05/85 by Steve Herbst: Moved dm_log_ back from dm_firstref_tv_, added
"	    $log_message to call dm_log_$from_arg_ptr.
" 03/11/85 by Lindsey Spratt:  Removed the $find_log entry (it's obsolete).
" 04/10/85 by Lee A. Newcomb:  Removed the obsolete $copy_log entry.  Removed
"             the unused $is_process_using_dm which duplicated $using_dm.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	dm_no_firstref_tv_


	macro	transfer
	entry	&1
&1:	tra	<&2>|[&3]
	&end

	transfer	dlr_close,dm_log_read_inner_,close

	transfer	dlr_deregister,dm_log_read_inner_,deregister

	transfer	dlr_free_message,dm_log_read_inner_,free_message

	transfer	dlr_get_log_uid,dm_log_read_inner_,get_log_uid

	transfer	dlr_hold_message,dm_log_read_inner_,hold_message

	transfer	dlr_next_message,dm_log_read_inner_,next_message

	transfer	dlr_open,dm_log_read_inner_,open

	transfer	dlr_position_sequence,dm_log_read_inner_,position_sequence

	transfer	dlr_position_time,dm_log_read_inner_,position_time

	transfer	dlr_prev_message,dm_log_read_inner_,prev_message

	transfer	dlr_register,dm_log_read_inner_,register

	transfer	dlr_update,dm_log_read_inner_,update

	transfer	get_aim_dir,dm_per_system_,get_aim_dir

	transfer	get_bootload_dir,dm_per_system_,get_bootload_dir

	transfer	get_enabled_bootload_dirname,dm_per_system_,get_enabled_bootload_dirname

	transfer	get_system_dir,dm_per_system_,get_system_dir

	transfer	initialize_system,dm_initializer_,dm_initializer_

	transfer	log,dm_log_,dm_log_

	transfer	log_message,dm_log_,from_arg_ptr

	transfer	set_journal_stamps,dm_no_firstref_util_,set_journal_stamps

	transfer	set_system_dir,dm_per_system_,set_system_dir

	transfer	set_system_state,dm_per_system_,set_system_state

	transfer  using_dm,dm_no_firstref_util_,using_dm

	end




		    dm_no_firstref_util_.pl1        11/05/86  1221.9r w 11/04/86  1033.6       98748



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

/*  DESCRIPTION:

     This is a general repository for little programs for DMS which may
not have the DM first-reference trap sprung.  Its current residents are:

   set_journal_stamps:	allows manual setting of all time stamps
			in dm_journal_seg_ to an arbitrary time.
			intended for emergency use.  Invoked through
			dm_admin_gate_.

   terminate_dm:		uncombines the linkage section of all segments
			combined by the DM first-reference trap (e.g.,
			*_firstref_tv_).  This resets the fref trap
			and makes Data Management unavailable to the
			user until the fref taps are tripped again.
			Called as part of tm_$user_shutdown and should
			only be available in the DM ring.

   using_dm:		returns "1"b if Data Management is available
			(bound_dm_is_inner_ is initiated), else "0"b.

   get_log_path		returns the pathname of the DM system log.
*/

/*  HISTORY:
Written by Lee A. Newcomb, 01/07/83.
Modified:
03/07/83 by L. A. Newcomb: to terminate old_dm_system_data_ ref name.
04/23/83 by L. A. Newcomb:  changed the star-name used by
            find_old_bootload_dir to match new name created via
	  request_id_ subr.
04/26/83 by L. A. Newcomb:  Again fixed the starname used to find an old DMS
            bootload directory.
08/17/83 by M. Pandolf: to add set_journal_stamps and get_system_data.
11/29/83 by S. Herbst: to add terminate_dm and using_dm.
01/26/84 by S. Herbst: made $using_dm check that DM_SEGMENT_NAME's linkage
	  section has been combined.
05/11/84 by Lee A. Newcomb: to have $terminate_dm work for an unbound version
	  of DM by terminating single refname fm_'s, bjm_'s, and lm_'s
	  inner ring TV before terminating tm_firstref_tv_.
06/08/84 by Lindsey L. Spratt:  Added the *data_ modules to the list of
            refnames to be terminated by the $terminate_dm entry.  This is
            necessary to ensure that any per-process static data associated
            with these data segments is gotten rid of. Also, added the
	  dm_journal_seg_ and dm_aim_dir_util_ refnames to be explicitly
	  terminated.
06/12/84 by Lindsey L. Spratt:  Changed $terminate_dm to terminate all of the
            DM_SEGMENT_NAMES in all of the rings from get_ring_() to
            OUTERMOST_RING (7).
07/31/84 by Lee A. Newcomb:  added entries $get_daemon_logout_time,
	  $get_system_state, $get_user_bump_time, and
	  $get_user_shutdown_time.
09/27/84 by Lee A. Newcomb:  added the entries get_(begin_shutdown
            shutdown_warning)_time and fixed $get_user_shutdown_time to
	  not use dm_system_data_$initializer_shutdown_time which has
	  been renamed to $user_shutdown_time.
12/02/84 by Lindsey L. Spratt:  Removed the obsolete $get_system_data entry.
            Added $get_initialization_time.
12/03/84 by Stanford S. Cox: Chg refs from *inner_ring_tv_ to =firstref_tv_
12/05/84 by Lindsey L. Spratt:  Removed dm_aim_dir_util_ from the
            DM_SEGMENT_NAMES array as it's obsolete.  Made minor format
            changes.
12/07/84 by Lindsey L. Spratt:  Copied from dm_util_.  Removed all of the
            entries except using_dm, terminate_dm, and set_journal_stamps.
            The removed entries are in dm_firstref_util_.
12/07/84 by R. Michael Tague:  Changed $terminate_dm to wipe out
            dm_system_data_$initializer_processid if we are the Daemon.
02/07/85 by Steve Herbst: Added $get_log_path.
02/19/85 by Lindsey L. Spratt:  Changed $terminate_dm to use
            dm_misc_util_$is_using_dm to determine if DM is in use, rather
            than simply check if the tm_firstref_tv_ name could be found by
            $fs_get_seg_ptr.  Change $terminate_dm to use term_$nomakeunknown
            rather than term_$refname, so it only un-combines the linkages on
            the refernce names in DM_SEGMENT_NAMES.  Changed $is_using_dm to
            set the validation level to the ring of execution before checking
            that tm_firstref_tv_ has a combined linkage.
02/27/85 by Lindsey L. Spratt:  Removed lm_data_ from DM_SEGMENT_NAMES, since
            it resides in bound_dm_ (which is not to be terminated in any way
            by $terminate_dm).
04/11/85 by Lee A. Newcomb:  To also do a term_$nomakeunknown of
            dm_firstref_tv_.  Fixed to copy input paramter to
            $set_journal_stamps to local.  Changed some names to correspond
            to project standards.
05/10/85 by R. Michael Tague:  Removed all references to dm_journal_seg_ and
            replaced them with calls to dm_hcs_$(get_time_stamp n_journals).
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo,^inddcls,dclind5,idind35,linecom */
%page;
dm_no_firstref_util_$set_journal_stamps:
   proc (p_time, p_code);

/* START OF DECLARATIONS */

/* Parameter */
dcl  (
     p_log_path			char (*),		/* O: returned by $get_log_path */
     p_time			fixed bin (71),	/* I: new time for journal stamps */
     p_code			fixed bin (35)	/* O: normal error code, recovery fails if ^= 0 */
     )				parameter;

/* Automatic */
dcl  (
     aim_dir			char (168),	/* DM per-AIM directory pathname */
     code				fixed bin (35),	/* local error code holder */
     is_using_dm			bit (1) aligned init (NO),
     journal_ix			fixed bin,	/* index into dm_journal_seg_ */
     loop_index			fixed bin,	/* for general looping through arrays */
     lot_ptr			ptr,		/* ptr to its linkage offset table */
     new_journal_stamp_time		fixed bin (71) init (0),
						/* local copy of p_time */
     saved_level			fixed bin init (0), /* the validation level as set by this programs caller. */
     seg_ptr			ptr,		/* ptr to seg init'd with refname DM_SEGMENT_NAMES (4) */
     segno			fixed bin,	/* its segment number */
     validation_level		fixed bin init (0)
     )				automatic;

/* Builtin */
dcl  (addr, baseno, binary, dim, length, null, stackbaseptr)
				builtin;

/* Condition */
dcl  cleanup			condition;

/* Constant */
dcl  (
     DM_LOG_NAME			char (32) int static
				options (constant)
				init ("dm_system_log"),
     DM_SEGMENT_NAMES		char (32) dim (10)	/* all must be known to be using DM, */
				init ("bjm_firstref_tv_",
						/* tm_firstref_tv_ is used as the sentinel */
				"fm_firstref_tv_", "lm_firstref_tv_",
				"tm_firstref_tv_", "bjm_data_",
				"dm_data_", "dm_journal_seg_",
				"dm_system_data_", "fm_data_",
				"dm_firstref_tv_"),
     NO				init ("0"b) bit (1) aligned,
     YES				init ("1"b) bit (1) aligned,
     DM_JOURNAL_SEG_SEGNAME_IDX	init (7) fixed bin,
     DM_SYSTEM_DATA_SEGNAME_IDX	init (8) fixed bin,
     TM_FIRSTREF_TV_SEGNAME_IDX	init (4) fixed bin
     )				int static options (constant);

/* Entry */
dcl  (
     cu_$level_get			entry (fixed bin),
     cu_$level_set			entry (fixed bin),
     dm_hcs_$get_n_journals		entry () returns (fixed bin),
     dm_hcs_$get_journal_stamp	entry (fixed bin) returns (fixed bin (71)),
     dm_hcs_$set_journal_stamp	entry (fixed bin, fixed bin (71),
				fixed bin (35)),
     dm_misc_util_$get_aim_dir	entry (char (*)),
     dm_misc_util_$is_process_using_dm	entry () returns (bit (1) aligned),
     get_ring_			entry () returns (fixed bin (3)),
     get_process_id_		entry () returns (bit (36)),
     hcs_$fs_get_seg_ptr		entry (char (*), ptr, fixed bin (35)),
     pathname_			entry (char (*), char (*))
				returns (char (168)),
     term_$refname			entry (char (*), fixed bin (35)),
     term_$nomakeunknown		entry (ptr, fixed bin (35))
     )				external;

/* External */
dcl  (
     dm_error_$no_user_dm		fixed bin (35),
     dm_system_data_$initializer_processid
				bit (36) aligned
     )				external static;

/* END OF DECLARATIONS */
%page;
/* dm_no_firstref_util_$set_journal_stamps:	/* repeat for reader */
/*    proc (p_time, p_code);					*/

/* copy input parameter to local storage */
   new_journal_stamp_time = p_time;

/* set the time stamp on the journals only toward the future */

   do journal_ix = 1 to dm_hcs_$get_n_journals ();
      if dm_hcs_$get_journal_stamp (journal_ix) < new_journal_stamp_time then
         call dm_hcs_$set_journal_stamp (journal_ix, new_journal_stamp_time, p_code);
   end;

   return;

/* end dm_no_firstref_util_$set_journal_stamps; */
%page;
dm_no_firstref_util_$terminate_dm:
   entry (p_code);

/* DM_SEGMENT_NAMES can only be known the ring-of-execution.   */

   call cu_$level_get (saved_level);

   on cleanup call cu_$level_set (saved_level);

   call cu_$level_set (get_ring_ ());

   if ^dm_misc_util_$is_process_using_dm () then
      call TD_RETURN (dm_error_$no_user_dm);

   if dm_system_data_$initializer_processid = get_process_id_ () then
      dm_system_data_$initializer_processid = "0"b;

   do loop_index = 1 to dim (DM_SEGMENT_NAMES, 1);
      call hcs_$fs_get_seg_ptr (DM_SEGMENT_NAMES (loop_index), seg_ptr, code);

      if seg_ptr ^= null () then
         call term_$nomakeunknown (seg_ptr, code);

   end;

   call term_$refname (DM_SEGMENT_NAMES (DM_SYSTEM_DATA_SEGNAME_IDX), code);
   call term_$refname (DM_SEGMENT_NAMES (DM_JOURNAL_SEG_SEGNAME_IDX), code);

   call TD_RETURN (0);

TD_MAIN_RETURN:
   return;

TD_RETURN:
   proc (tdr_p_code);
dcl  tdr_p_code			fixed bin (35) parm;
   p_code = tdr_p_code;
   call cu_$level_set (saved_level);
   goto TD_MAIN_RETURN;
   end TD_RETURN;

/* end dm_no_firstref_util_$terminate_dm; */
%page;
dm_no_firstref_util_$using_dm:
   entry returns (bit (1) aligned);

/* NOTE: This code will have to be improved if it turns out that  */
/* DM_SEGMENT_NAMES can be known in rings other than the DM ring. */
/* See $terminate_dm for more info on DM_SEGMENT_NAMES usage.     */

   call cu_$level_get (saved_level);

   on cleanup call cu_$level_set (saved_level);

   call cu_$level_set (get_ring_ ());

   call hcs_$fs_get_seg_ptr (DM_SEGMENT_NAMES (TM_FIRSTREF_TV_SEGNAME_IDX),
        seg_ptr, 0);
   if seg_ptr = null then
      call UD_RETURN (NO);

   segno = binary (baseno (seg_ptr));
   lot_ptr = stackbaseptr () -> stack_header.lot_ptr;
   if baseno (lot_ptr -> lot.lp (segno)) ^= "0"b then
      call UD_RETURN (YES);
   else call UD_RETURN (NO);

UD_MAIN_RETURN:
   return (is_using_dm);

UD_RETURN:
   proc (udr_p_is_using_dm);
dcl  udr_p_is_using_dm		bit (1) aligned parm;
   is_using_dm = udr_p_is_using_dm;
   call cu_$level_set (saved_level);
   goto UD_MAIN_RETURN;
   end UD_RETURN;

/* end dm_no_firstref_util_$using_dm; */
%page;
dm_no_firstref_util_$get_log_path:
   entry (p_log_path);

   call dm_misc_util_$get_aim_dir (aim_dir);
   p_log_path = pathname_ (pathname_ (aim_dir, "logs"), DM_LOG_NAME);

   return;

/* end dm_no_firstref_util_$get_log_path; */
%page;
%include lot;
%page;
%include stack_header;
   end dm_no_firstref_util_$set_journal_stamps;




		    dm_per_system_.pl1              04/24/85  1016.3re  04/24/85  0803.1      405729



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

/*  DESCRIPTION:

	Utility for initializing per-system segments (actually, they are
     per-AIM authorization segments, but they appear to most everyone else
     as per-system segments).  All entries use the sub_err_ program to
     report any errors that occur.  It is recommended that callers wishing
     to catch non-fatal errors handle the sub_error_ condition.  None of
     the entries called only at system initialization time produce
     recoverable errors.

	There are three types of entries to this program: DM
     initialization and shutdown, per-system file/table handling, and DM
     directory utilities.  The entries are described in these groups below;
     see dm_per_system_.info for more help.

	NOTE:  the system_low AIM classification is special cased to use
     the "system_low" dir under the DM system dir.  This code should be
     removed when all sites wanting to use DM from system_low have
     installed the MR11 version of convert_access_class_; it is being left
     in currently for our controlled release sites.


     Initialization & Shutdown Entries:

     init: create the per-bootload directory with the name of the enabled
	per-bootload directory with a ".init" suffix, create the segment
	dm_system_data_ in the new dir, and populate it with the contents
	of dm_system_data_template_ as found via (DM ring) search rules.
	If an active DM bootload exists, try to take over the Daemon
	caretaker function.  If we takeover an existing system, either a
	running or partially shutdown one, we reset any administratively
	set shutdown information (i.e., the Daemon will use the Multics
	shutdown time as the sole source of DM shutdown scheduling after
	takeover) and make sure transactions can be started.

     enable:  make the per-bootload directory accessible, by deleting the
	".init" suffix from the name.

     cleanup:  called if there is an error between initialization and enable.
	Deletes the temporary initialization directory if it was created.

     set_system_state:  called to set the current state of a DMS if the
	process doing the setting is outside the DM ring.  Programs
	executing in the DM ring will directly set the state.

     File/Table Handling Entries:

     create:  creates a segment in the per-bootload directory, and makes
	it known.

     alloc:  allocates a block in the area located in dm_system_data_.

     initiate:  used in per-process initialization to make a segment known
	which was created by the create entry in per-system initialization.

     Directory Handling Entries:  (NOTE: these entries are in
	dm_per_system_ because of their ties with the $init and $enable
	entries.)

     get_aim_dir: gets the DM directory under the DM system directory for
	the calling process' AIM authorization.

     get_bootload_dir: get the DM bootload directory under the AIM dir for
	the current process.  The name is taken from the Multics system
	up time and can have a .init suffix if the Daemon uses it and is
	in the process of booting a system.  For normal users, the
	returned name will never have .init added.

     get_enabled_bootload_dirname: returns the entryname portion of the
	bootload directory pathname that will be used when a DMS is
	enabled, regardless of the current state of the DMS.  This is
	useful for things like part two before journal manager per-system
	initialization which must store the entryname of the bootload
	directory before the .init suffix has been removed (e.g., the
	location of the default system before journal.

     get_system_dir:  current system directory for the calling process.

     set_system_dir:  to set the system dir for the calling process.  Only
	recommended for development and testing, but is unprivileged.
*/

/*  HISTORY:

Written by J. Bongiovanni, 08/15/82.
Modified:
11/11/82 by L. A. Newcomb: to add in the recovery entrypoint and have init,
	  enable, and recovery set dm_system_data_$current_dm_state,
	  and change the name given to the bootload dirs.
12/08/82 by M. Pandolf: to tune dm_system_data_ with site generated parameters.
03/09/83 by L. A. Newcomb: create directory & files write brackets of the
	  DMS ring and read brackets of ring 5.
03/15/83 by L. A. Newcomb: fill in dm_system_data_$initializer_name.
04/22/83 by L. A. Newcomb:  changed the per-bootload dir name to work off of
            the request_id_ subr and fixed problem of needing to know the name
            of the enabled per-bootload dir name in part-2 initialization
            BEFORE it is renamed.  For less problems, we truncate the seconds
	  and microseconds off the request ID generated.
05/17/83 by L. A. Newcomb:  Removed the recovery entrypoint (dm_initializer_
            calls dm_recovery_ directly).  Started integration of
            per-AIM control file parameters and merging dm_aim_dir_util_ into
            this program for consistency.  All code parameters are now
            obsolete as sub_err_ is used, and are being purged.
06/13/83 by L. A. Newcomb:  Added creation of the privileged command message
            segment for passing abitrary commands to a running Daemon.
03/05/84 by L. A. Newcomb:  changed to use the include file dm_system_states
            (renamed from dm_statuses); also changed creation of the
            per-bootload directory and tables to have ring brackets of the DM
            ring instead of DM ring, 5, 5 as it was for debugging.
04/06/84 by Lindsey L. Spratt:  Added handling of the intermediate shutdown
            system states to the takeover procedure, TRY_DM_SYSTEM_TAKEOVER.
05/29/84 by Lindsey L. Spratt:  Changed to use version 2 of dm_system_config.
            Added use of the CHECK_VERSION proc.
08/02/84 by Lee A. Newcomb:  added the entries $set_system_state and
	  $start_shutdown.
08/13/84 by Lee A. Newcomb:  removed understanding of all DMS shutdown states
	  from the TRY_DM_SYSTEM_TAKEOVER int. proc. except final shutdown.
09/05/84 by Lee A. Newcomb:  Renamed dm_system_data_$initializer_shutdown_time
	  to be $user_shutdown_time to agree with dm_system_data_ changes.
09/27/84 by Lee A. Newcomb:  moved $start_shutdown to
            dm_dmn_system_shutdown_$schedule and fixed error of not always
            calling cu_$level_set before returning.
11/05/84 by Lindsey L. Spratt:  Changed to use dm_system_data_template_ and 
	  old_dm_system_data_, instead of just dm_system_data_.  Changed to
	  use ERROR_RETURN, and to build pathnames for error msgs using
	  pathname_.  Changed to only establish the cleanup handler once in
	  the $init entry, changed CLEAN_UP_INIT to use FINISH_INIT.
11/20/84 by Lee A. Newcomb:  moved all DM directory handling to this module,
	  obsoleting dm_aim_dir_util_, at the same time, removing the notion
	  of an AIM control segment and using convert_authorization_$encode
	  to find per-AIM dirs; changed ERROR_RETURN to be "options
	  (variable)" (kudos to CLJones), changed to always use
	  dm_misc_util_ to get to the directory entries, and made internal
	  proc variables use a prefix of the proc's initials as per project
	  standards.
12/02/84 by Lee A. Newcomb:  fixed a bug in takeover of an active DMS where we
	  only used the enabled bootload dir name, not its path, to find the
	  per-bootload tables; removed obsolete p_initializer_event_channel
	  parameter from $enable.
12/07/84 by Lee A. Newcomb:  Changed myname to the constant MYNAME as sub_err_
	  only allows 32 chars. for the module name and octal garbage was
	  resulting from the char varying; added the entryname variable
	  for use in reporting errors.
12/09/84 by Lee A. Newcomb:  Fixed to report process id's in octal (had
	  used ^a instead of ^.3b in ioa_ strings).
12/12/84 by Lindsey Spratt:  Fixed to everywhere use DM_SYSTEM_STATE_RUNNING
	  to test and indicate  a successful takeover, even when the actual
	  state is one of the intermediate shutdown states.
02/19/85 by Lee A. Newcomb:  Fixed TRY_DM_SYSTEM_TAKEOVER to allow rebooting
            if the system was partially shutdown and to reset the
            administratively set shutdown information on ANY takeover; fixed
            so we can boot a new DMS in the same Multics bootload if the
            previous bootload completely finished; changed to use ^w instead
            of ^.3b in ioa_ strings for octal output; fixed special case of
            system_low per-AIM dir to use "system_low" instead of per-system
            dir.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/20/85 by R. Michael Tague: Removed the daemon message segment creation.
04/09/85 by Lee A. Newcomb:  To use convert_access_class_ and not the obsolete
            convert_authorization_.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;
dm_per_system_$init:
   proc (p_initializer_event_channel) returns (char (4) aligned);

/* START OF DECLARATIONS */

/* Parameter */
dcl  (
     p_aim_directory		char (*),		/* per-AIM dir for current process */
     p_block_ptr			ptr,		/* Pointer to allocated block */
     p_bootload_dir			char (*),		/* Bootload directory name */
     p_initializer_event_channel	fixed bin (71),	/* event channel to talk to Daemon on */
     p_n_words			fixed bin (18),	/* Size of block to allocate */
     p_new_system_state		char (4) aligned,	/* for $set_system_state */
     p_reference_name		char (*),		/* Reference name */
     p_segment_name			char (*),		/* Name of segment to create */
     p_seg_ptr			ptr,		/* Pointer to created segment */
     p_system_directory		char (*)		/* Current system dir for DMS */
     )				parameter;

/* Automatic */

dcl  (
     aim_dir			char (168),	/* current DM AIM dir. for this process */
     aim_dir_name			char (32),	/* current AIM dir ename */
     areap			ptr,		/* $alloc, ptr to area in dm_system_data_ */
     block_ptr			ptr,		/* $alloc, ptr to allocation in dm_system_data_ area */
     bit_count			fixed bin (24),	/* $init, for setting bit count on dm_system_data_ */
     bootload_dir_name		char (32),
     code				fixed bin (35),	/* status/error code returned from some calls */
     current_bootload_directory	char (168),
     dm_system_copyp		ptr,		/* $init, loc. of per-bootload copy of dm_system_data_ */
     dm_system_data_template_ptr	ptr,		/* loc. of installed dm_system_data_ to copy */
     enabled_bootload_dir_name	char (32),
     entrypoint_name		char (32) varying,	/* globally used by ERROR_RETURN */
     initialization_bootload_dir_name	char (32),
     initialization_bootload_directory			/* $init, curr. name of per-bootload dir. */
				char (168),
     level			fixed bin,	/* saved validation level */
     1 local_area_info		aligned like area_info,
     n_words			fixed bin (18),	/* $init, for making copy of installed dm_system_data_ */
						/* $alloc, block size to allocate */
     ring_brackets			dim (3) fixed bin (3),
						/* $init & $create, so seg. creation works in testing */
     seg_ptr			ptr,
     segname			char (32),
     system_dir			char (168),
     temp_dir			char (168),
     temp_dir_name			char (32)
     )				automatic;

/* Based */
dcl  based_area			area based (areap),
     block			dim (n_words) bit (36) aligned
				based (block_ptr),
     seg_array			dim (n_words) bit (36) aligned based;

/* Builtin */
dcl  (addr, bin, bit, clock, divide, null, ptr, substr, unspec)
				builtin;

/* Condition */
dcl  (area, cleanup, sub_error_)	condition;

/* Constant */
dcl  (
     ACL_ID			char (32) unaligned init ("*.*.*"),
     ENABLED_BOOTLOAD_DIR_NAME	bit (1) aligned init ("0"b),
						/* for GET_BOOTLOAD_DIR_NAME int proc */
     INITIALIZATION_BOOTLOAD_DIR_NAME	bit (1) aligned init ("1"b),
						/* for GET_BOOTLOAD_DIR_NAME int proc */
     IOA_GENERAL_RS_NO_NEW_LINE	bit (1) aligned init ("0"b),
     IOA_GENERAL_RS_DONT_PAD		bit (1) aligned init ("1"b),
     UNLOCK_CONFIG			bit (1) aligned init ("1"b),
						/* for FINISH_INIT int. proc.*/
     DONT_UNLOCK_CONFIG		bit (1) aligned init ("0"b),
						/* for FINISH_INIT int. proc.*/
     MYNAME			char (32) init ("dm_per_system_"),
     OLD_SYS_SEG			char (19) init ("old_dm_system_data_"),
     SYS_SEG			char (15) init ("dm_system_data_"),
     SYS_SEG_TEMPLATE		char (24)
				init ("dm_system_data_template_")
     )				internal static options (constant);

/* Entry */

dcl  (
     convert_access_class_$encode	entry (bit (72) aligned, char (*)),
     cu_$arg_list_ptr		entry (ptr),
     cu_$level_get			entry (fixed bin),
     cu_$level_set			entry (fixed bin),
     define_area_			entry (ptr, fixed bin (35)),
     delete_$path			entry (char (*), char (*), bit (6),
				char (*), fixed bin (35)),
     delete_$ptr			entry (ptr, bit (6), char (*),
				fixed bin (35)),
     dm_check_configuration_		entry (ptr),
     dm_find_configuration_		entry () returns (ptr),
     dm_find_configuration_$terminate	entry (ptr),
     dm_load_configuration_		entry (ptr),
     dm_lock_configuration_		entry (ptr),
     dm_lock_configuration_$unlock	entry (ptr),
     dm_misc_util_$log		entry () options (variable),
     dm_misc_util_$get_aim_dir	entry (char (*)),
     dm_misc_util_$get_bootload_dir	entry (char (*)),
     dm_misc_util_$get_enabled_bootload_dirname
				entry () returns (char (32)),
     dm_misc_util_$get_system_dir	entry (char (*)),
     dm_misc_util_$is_process_using_dm	entry () returns (bit (1) aligned),
     expand_pathname_		entry (char (*), char (*), char (*),
				fixed bin (35)),
     get_authorization_		entry () returns (bit (72) aligned),
     get_group_id_$tag_star		entry () returns (char (32)),
     get_process_id_		entry () returns (bit (36)),
     get_ring_			entry () returns (fixed bin (3)),
     hcs_$append_branchx		entry (char (*), char (*),
				fixed bin (5), (3) fixed bin (3),
				char (*), fixed bin (1), fixed bin (1),
				fixed bin (24), fixed bin (35)),
     hcs_$chname_file		entry (char (*), char (*), char (*),
				char (*), fixed bin (35)),
     hcs_$initiate			entry (char (*), char (*), char (*),
				fixed bin (1), fixed bin (2), ptr,
				fixed bin (35)),
     hcs_$set_bc_seg		entry (ptr, fixed bin (24),
				fixed bin (35)),
     hcs_$status_minf		entry (char (*), char (*),
				fixed bin (1), fixed bin (2),
				fixed bin (24), fixed bin (35)),
     hcs_$status_mins		entry (ptr, fixed bin (2),
				fixed bin (24), fixed bin (35)),
     hcs_$validate_processid		entry (bit (36) aligned,
				fixed bin (35)),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned),
     pathname_			entry (char (*), char (*))
				returns (char (168)),
     request_id_			entry (fixed bin (71))
				returns (char (19)),
     sub_err_			entry options (variable),
     system_info_$timeup		entry (fixed bin (71)),
     term_$seg_ptr			entry (ptr, fixed bin (35)),
     term_$single_refname		entry (char (*), fixed bin (35)),
     transaction_manager_$begins_on	entry ()
     )				external;

/* External */
dcl  (
     (
     dm_error_$area_overflow,
     dm_error_$per_system_not_init
     )				fixed bin (35),
     dm_system_data_template_$,
     dm_system_data_$,
     dm_system_data_$area_rel		bit (18) aligned,
     dm_system_data_$command_ms_name	char (32),
     dm_system_data_$current_dm_state	char (4) aligned,
     dm_system_data_$initialized	bit (1) aligned,
     dm_system_data_$initializer_name	char (32),
     dm_system_data_$initializer_processid
				bit (36) aligned,
     (
     dm_system_data_$bootload_time,
     dm_system_data_$initializer_event_chn,
     dm_system_data_$initialization_time,
     dm_system_data_$saved_begin_shutdown_time,
     dm_system_data_$saved_daemon_logout_time,
     dm_system_data_$saved_user_bump_time,
     dm_system_data_$saved_user_shutdown_time,
     dm_system_data_$saved_user_warning_time
     )				fixed bin (71),
     dm_system_data_$saved_shutdown_reason
				char (64) aligned,
     (
     error_table_$namedup,
     error_table_$segknown,
     error_table_$unimplemented_version
     )				fixed bin (35),
     old_dm_system_data_$initializer_processid
				bit (36) aligned,
     old_dm_system_data_$initializer_name
				char (32),
     old_dm_system_data_$current_dm_state
				char (4) aligned,
     sys_info$max_seg_size		fixed bin (19)
     )				external static;

/* Static */
dcl  (
     dms_initializer_process		bit (1) aligned init (""b),
						/* are we doing per-system initialization */
     multics_bootload_request_id_str	char (17) unaligned init (""),
						/* for per-bootload dir. naming */
     system_dir_in_static		char (168)
				init (">site>Data_Management")
     )				internal static;

/* END OF DECLARATIONS */
%page;
/*  dm_per_system_$init: proc (p_initializer_event_channel) returns (char (4) aligned);

 - Find the per-AIM directory
 - Make sure the per-bootload directory does not already exist (try to adopt
     if one does)
 - Create a directory subordinate to it with a unique name, so that
	it cannot be accessed (yet) by Data Management users.
 - Copy dm_system_data_template_ to this directory with the name
	dm_system_data_ and make it known with ref. name dm_system_data_.
 - Initialize dm_system_data_ values.
*/

   entrypoint_name = "init";

   dm_system_data_template_ptr = null ();		/* don't know where installed dm_system_data_template_ is */
   dm_system_copyp = null ();				/* haven't made dm_system_data_ copy yet */
   dm_system_config_ptr = null ();			/* have not found per-AIM control file */

   dms_initializer_process = ""b;			/* assume the system is running for the moment */

   call cu_$level_get (level);
   on cleanup call CLEAN_UP_INIT ();
   call cu_$level_set (get_ring_ ());

   call dm_misc_util_$get_aim_dir (aim_dir);

/* get ptr to the per-AIM configuration file and lock it.  This is our */
/* main defense against multiple processes attempting to bootload a DMS */
/* at the same AIM level in the same Multics bootload. */

   dm_system_config_ptr = dm_find_configuration_ ();
   call CHECK_VERSION (dm_system_config.version, DM_CONFIG_VERSION_2,
        "dm_system_config");

   call dm_lock_configuration_ (dm_system_config_ptr);
   call dm_check_configuration_ (dm_system_config_ptr);

/* The configuration file is now locked.  See if a current bootload exists */

   enabled_bootload_dir_name = dm_misc_util_$get_enabled_bootload_dirname ();
   call hcs_$status_minf (aim_dir, enabled_bootload_dir_name, 0, (0), (0),
        code);
   if code = 0 then do;				/* if exists, try to adopt */
						/* takeover will fail with sub_err_ call if system has */
						/* a caretaker Daemon already */
      if TRY_DM_SYSTEM_TAKEOVER (p_initializer_event_channel,
	 pathname_ (aim_dir, enabled_bootload_dir_name))
	 = DM_SYSTEM_STATE_RUNNING then do;		/* successful takeover */
         call FINISH_INIT (UNLOCK_CONFIG);
         return (DM_SYSTEM_STATE_RUNNING);		/* Must be the running state if we took over */
      end;
   end;

   dms_initializer_process = "1"b;			/* no takeover to do, we will do initialization */
   ring_brackets (1), ring_brackets (2), ring_brackets (3) = get_ring_ ();
						/* DMS ring */

%page;
/* Create a temporary initialization bootload directory for the */
/* DMS tables in the per-AIM directory */

   initialization_bootload_dir_name =
        GET_BOOTLOAD_DIR_NAME (INITIALIZATION_BOOTLOAD_DIR_NAME);
   call hcs_$append_branchx (aim_dir, initialization_bootload_dir_name,
        SMA_ACCESS_BIN, ring_brackets, ACL_ID, 1, 0, 0, code);
   if code = error_table_$namedup then do;		/* delete old, dead one and start fresh */
      call delete_$path (aim_dir, initialization_bootload_dir_name,
	 "101000"b /* force,dir */, MYNAME, code);
      if code ^= 0 then
         call ERROR_RETURN (code,
	    "Could not delete old initialization bootload directory ^a.",
	    pathname_ (aim_dir, initialization_bootload_dir_name));
						/* start fresh */
      call hcs_$append_branchx (aim_dir, initialization_bootload_dir_name,
	 SMA_ACCESS_BIN, ring_brackets, ACL_ID, 1, 0, 0, code);
   end;
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Could not create initialization bootload directory ^a.",
	 pathname_ (aim_dir, initialization_bootload_dir_name));

   call dm_misc_util_$get_bootload_dir (initialization_bootload_directory);

/* Now create a segment to be dm_system_data_, initiate it with the	*/
/* required reference name, and copy the template system data segment	*/
/* to the newly created one.  Note we find the template via search	*/
/* rules in the DM ring.					*/

   call hcs_$append_branchx (initialization_bootload_directory, SYS_SEG,
        RW_ACCESS_BIN, ring_brackets, ACL_ID, 0, 0, 0, code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Cannot create system data segment (^a) for this bootload in ^a.",
	 SYS_SEG, initialization_bootload_directory);

   call hcs_$initiate (initialization_bootload_directory, SYS_SEG, SYS_SEG, 0,
        0, dm_system_copyp, code);
   if code ^= 0 & code ^= error_table_$segknown then
      call ERROR_RETURN (code,
	 "Cannot initiate system data segment ^a for this bootload, with reference name ^a.",
	 pathname_ (initialization_bootload_directory, SYS_SEG), SYS_SEG);

   dm_system_data_template_ptr = addr (dm_system_data_template_$);
   call hcs_$status_mins (dm_system_data_template_ptr, (0), bit_count, code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Cannot find out bit count of system data segment template ^a.",
	 SYS_SEG_TEMPLATE);

   n_words = divide (bit_count + 35, 36, 17);		/* copy installed to bootload version */
   unspec (dm_system_copyp -> seg_array) =
        unspec (dm_system_data_template_ptr -> seg_array);


   call hcs_$set_bc_seg (dm_system_copyp, bit_count, code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Cannot set bit count on bootload version of system data segment: ^a.",
	 pathname_ (initialization_bootload_directory, SYS_SEG));

   dm_system_data_$current_dm_state = DM_SYSTEM_STATE_INITIALIZING;
   dm_system_data_$initialization_time = clock ();
   call system_info_$timeup (dm_system_data_$bootload_time);
   dm_system_data_$initializer_processid = get_process_id_ ();
   dm_system_data_$initializer_name = get_group_id_$tag_star ();
   dm_system_data_$initializer_event_chn = p_initializer_event_channel;
   dm_system_data_$area_rel =
        bit (bin (divide (n_words + 1, 2, 17) * 2, 18), 18);

   unspec (local_area_info) = ""b;
   local_area_info.version = area_info_version_1;
   local_area_info.control.zero_on_alloc = "1"b;
   local_area_info.owner = SYS_SEG;
   local_area_info.size =
        sys_info$max_seg_size - bin (dm_system_data_$area_rel, 18);
   local_area_info.areap = ptr (dm_system_copyp, dm_system_data_$area_rel);

   call define_area_ (addr (local_area_info), code);
   if code ^= 0 then
      call ERROR_RETURN (code, "Cannot create area in system data segment ^a.",
	 pathname_ (initialization_bootload_directory, SYS_SEG));

   call dm_load_configuration_ (dm_system_config_ptr);	/* tune dm_system_data_ */

   call FINISH_INIT (DONT_UNLOCK_CONFIG);

   return (dm_system_data_$current_dm_state);

/* end dm_per_system_$init; */
%page;
dm_per_system_$enable:
   entry ();

   entrypoint_name = "enable";			/* for error reporting */

/* Now we let the users at the system, but finish some housecleaning first. */
/* We must set the indicators in the system data segment to show that */
/* initialization has finished, rename the initialization bootload directory */
/* so users can find it, and unlock the per-AIM control file */

   if dm_system_data_$current_dm_state = DM_SYSTEM_STATE_UNDEFINED
        | dm_system_data_$current_dm_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN
        then
      call ERROR_RETURN (dm_error_$per_system_not_init,
	 "Current Data Management state = ^a.",
	 (dm_system_data_$current_dm_state));

   dm_system_data_$initialized = "1"b;
   dm_system_data_$current_dm_state = DM_SYSTEM_STATE_RUNNING;

   call dm_misc_util_$get_aim_dir (aim_dir);

/* change bootload dir name to findable one */
/* if this call works, users may use the system */

   enabled_bootload_dir_name = dm_misc_util_$get_enabled_bootload_dirname ();
   initialization_bootload_dir_name =
        GET_BOOTLOAD_DIR_NAME (INITIALIZATION_BOOTLOAD_DIR_NAME);

   call cu_$level_get (level);
   on cleanup call RESET_VALIDATION_LEVEL ();
   call cu_$level_set (get_ring_ ());

   call hcs_$chname_file (aim_dir, initialization_bootload_dir_name,
        initialization_bootload_dir_name, enabled_bootload_dir_name, code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Cannot rename initialization bootload directory to an enabled name: ^a to ^a.",
	 pathname_ (aim_dir, initialization_bootload_dir_name),
	 enabled_bootload_dir_name);

   dm_system_config_ptr = dm_find_configuration_ ();	/* find control file for unlocking and termination */
   call dm_lock_configuration_$unlock (dm_system_config_ptr);
						/* free up the control file */
   call dm_find_configuration_$terminate (dm_system_config_ptr);
						/* cleanup address space */

   dms_initializer_process = "0"b;			/* at least we better be */

   call RESET_VALIDATION_LEVEL ();

   call RETURN ();

/* end dm_per_system_$enable; */
%page;
dm_per_system_$create:
   entry (p_segment_name, p_seg_ptr);

   entrypoint_name = "create";

/*  Create a segment in the per-bootload directory, make it known, and */
/*  return a pointer to it. */

   segname = p_segment_name;
   p_seg_ptr = null ();

   if dm_system_data_$current_dm_state = DM_SYSTEM_STATE_UNDEFINED
        | dm_system_data_$current_dm_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN
        then
      call ERROR_RETURN (dm_error_$per_system_not_init,
	 "Current Data Management state = ^a.",
	 (dm_system_data_$current_dm_state));


   call dm_misc_util_$get_bootload_dir (current_bootload_directory);
						/* external entry in this program */

   ring_brackets (1), ring_brackets (2), ring_brackets (3) = get_ring_ ();
						/* DMS ring */
   call cu_$level_get (level);
   on cleanup call RESET_VALIDATION_LEVEL ();
   call cu_$level_set (get_ring_ ());

   call hcs_$append_branchx (current_bootload_directory, segname,
        RW_ACCESS_BIN, ring_brackets, ACL_ID, 0, 0, 0, code);
   if code ^= 0 then
      call ERROR_RETURN (code, "Cannot create system segment ^a.",
	 pathname_ (current_bootload_directory, segname));

   call hcs_$initiate (current_bootload_directory, segname, "", 0, 0, seg_ptr,
        code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Cannot initiate newly created system segment ^a.",
	 pathname_ (current_bootload_directory, segname));

   call RESET_VALIDATION_LEVEL ();
   p_seg_ptr = seg_ptr;

   call RETURN ();

/* end dm_per_system_$create; */
%page;
dm_per_system_$alloc:
   entry (p_n_words, p_block_ptr);

   entrypoint_name = "alloc";

/*  allocate a block in the area in the system data segment */

   p_block_ptr = null ();
   n_words = p_n_words;

   if dm_system_data_$current_dm_state = DM_SYSTEM_STATE_UNDEFINED
        | dm_system_data_$current_dm_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN
        then
      call ERROR_RETURN (dm_error_$per_system_not_init,
	 "Current Data Management state = ^a.",
	 (dm_system_data_$current_dm_state));

   areap = ptr (addr (dm_system_data_$), dm_system_data_$area_rel);

   on area
      call ERROR_RETURN (dm_error_$area_overflow,
	 "Cannot do more allocation in system data area, # of words asked for = ^d.",
	 p_n_words);

   allocate block in (based_area) set (block_ptr);

   p_block_ptr = block_ptr;

   call RETURN ();

/* end dm_per_system_$alloc; */
%page;
dm_per_system_$cleanup:
   entry ();

   entrypoint_name = "cleanup";

/*  undo what we've done so far, only for dm_initializer_ to call */

   if ^dms_initializer_process then			/* we haven't anything to undo */
      call RETURN ();

   if dm_system_data_$current_dm_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN then
      call ERROR_RETURN (dm_error_$per_system_not_init,
	 "(Current) Data Management state = ^a.",
	 (dm_system_data_$current_dm_state));

   on sub_error_					/* ignore errors in next two calls */
      go to CLEANUP_PROC_DONE;
   call dm_misc_util_$get_aim_dir (aim_dir);

   dm_system_config_ptr = dm_find_configuration_ ();	/* so we can unlock it if locked */

   on sub_error_					/* don't miss the terminate of config file */
      go to CLEANUP_PROC_TERM_CONFIG_FILE;
   call dm_lock_configuration_$unlock (dm_system_config_ptr);

CLEANUP_PROC_TERM_CONFIG_FILE:
   on sub_error_					/* now back to original handling */
      go to CLEANUP_PROC_DONE;
   call dm_find_configuration_$terminate (dm_system_config_ptr);

   bootload_dir_name = GET_BOOTLOAD_DIR_NAME (dms_initializer_process);
   call delete_$path (aim_dir, bootload_dir_name, "001000"b /* dir */, "",
        code);

   revert sub_error_;

CLEANUP_PROC_DONE:
   call RETURN ();

/* end dm_per_system_$cleanup; */
%page;
dm_per_system_$initiate:
   entry (p_segment_name, p_reference_name, p_seg_ptr);

   entrypoint_name = "initiate";

/*  makes a segment in the per-bootload directory known and returns a */
/*  pointer to it. */

   if dm_system_data_$current_dm_state = DM_SYSTEM_STATE_UNDEFINED
        | dm_system_data_$current_dm_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN
        then
      call ERROR_RETURN (dm_error_$per_system_not_init,
	 "Current Data Management state = ^a.",
	 (dm_system_data_$current_dm_state));

   p_seg_ptr = null ();

   call dm_misc_util_$get_bootload_dir (current_bootload_directory);

   call cu_$level_get (level);
   on cleanup call RESET_VALIDATION_LEVEL ();
   call cu_$level_set (get_ring_ ());

   call hcs_$initiate (current_bootload_directory, p_segment_name,
        p_reference_name, 0, 0, p_seg_ptr, code);
   if p_seg_ptr = null () then
      call ERROR_RETURN (code,
	 "Cannot initiate system segment ^a with ref name of ^a.",
	 pathname_ (current_bootload_directory, p_segment_name),
	 p_reference_name);

   call RESET_VALIDATION_LEVEL ();

   call RETURN ();

/* end dm_per_system_$initiate; */
%page;
dm_per_system_$get_system_dir:
   entry (p_system_directory);

   entrypoint_name = "get_system_dir";

/*  get_system_dir - entry to get the system dir for the current process' */
/*  data management system.  We must verify the system dir exists before  */
/*  returning, however.					    */

   call expand_pathname_ (system_dir_in_static, temp_dir, temp_dir_name, code);
   if code ^= 0 then
      call ERROR_RETURN (code, "Unable to expand system directory path ^a.",
	 system_dir_in_static);

   call hcs_$status_minf (temp_dir, temp_dir_name, 0, 0, 0, code);
   if code ^= 0 then
      call ERROR_RETURN (code, "Unable to find system direcotry ^a.",
	 system_dir_in_static);

   p_system_directory = system_dir_in_static;

   call RETURN ();

/* end dm_per_system_$get_system_dir; */
%skip (4);
dm_per_system_$set_system_dir:
   entry (p_system_directory);

   entrypoint_name = "set_system_dir";

/* set the internal static variable which holds the process' current system */
/* directory.  This is only recommended for developers and testers of DM.   */

   if dm_misc_util_$is_process_using_dm () then
      call ERROR_RETURN (0,
	 "Cannot set DM system directory to ^a, you must do DM user shutdown first.",
	 p_system_directory);

   system_dir = p_system_directory;
   call expand_pathname_ (system_dir, temp_dir, temp_dir_name, code);
   if code ^= 0 then
      call ERROR_RETURN (code,
	 "Unable to set DM system directory to ^a, expand_pathname_ failed on it.",
	 system_dir);

   call hcs_$status_minf (temp_dir, temp_dir_name, 0, 0, 0, code);
   if code = 0 then					/* OK, set it */
      system_dir_in_static = pathname_ (temp_dir, temp_dir_name);
   else call ERROR_RETURN (code,
	   "Cannot set DM system directory to the non-existent directory ^a.",
	   system_dir);

   call RETURN ();

/* end dm_per_system_$set_system_dir; */
%page;
dm_per_system_$get_aim_dir:
   entry (p_aim_directory);

   entrypoint_name = "get_aim_dir";

/*  Entry to return the pathname of the per-AIM directory for this process */
/*  in the current DM system directory.   IF THERE IS NO AIM DIRECTORY FOR */
/*  THIS PROCESS' AUTHORIZATION, WE USE ERROR_RETURN.  We could instead    */
/*  let no error occur and let the firstref trap signal dm_not_available_, */
/*  but there are modules calling this without setting off the trap; and   */
/*  even if they did, it would imply there did exist an AIM dir giving     */
/*  hope a DMS would be booted when it cannot be.  The only exception is   */
/*  system_low since its AIM dir IS the system dir.		     */

   call convert_access_class_$encode (get_authorization_ (), aim_dir_name);
   call dm_misc_util_$get_system_dir (system_dir);
   if aim_dir_name = "" then
SYSTEM_LOW_PROCESS:
      p_aim_directory = pathname_ (system_dir, "system_low");
						/* it better exist */
   else
NON_SYSTEM_LOW_PROCESS:
      do;						/* verify AIM dir exists */
      call hcs_$status_minf (system_dir, aim_dir_name, 0, 0, 0, code);
      if code ^= 0 then
         call ERROR_RETURN (code,
	    "DM is not usable from the current AIM authorization, trying to find the directory ^a.",
	    pathname_ (system_dir, aim_dir_name));
      p_aim_directory = pathname_ (system_dir, aim_dir_name);
   end NON_SYSTEM_LOW_PROCESS;

   call RETURN ();

/* end dm_per_system_$get_aim_dir; */
%skip (4);
dm_per_system_$get_bootload_dir:
   entry (p_bootload_dir);

   entrypoint_name = "get_bootload_dir";

/*  Entry to return the name of the per-bootload directory for this      */
/*  bootload and AIM authorization.  It takes into account that the      */
/*  caller may be the Daemon process booting a new DMS.  We do not	   */
/*  report errors from this entry.				   */

   call dm_misc_util_$get_aim_dir (aim_dir);

   p_bootload_dir =
        pathname_ (aim_dir, GET_BOOTLOAD_DIR_NAME (dms_initializer_process));

   call RETURN ();

/* end dm_per_system_$get_bootload_dir; */
%skip (4);
dm_per_system_$get_enabled_bootload_dirname:
   entry () returns (char (32));

   entrypoint_name = "get_enabled_bootload_dirname";

/* entry to return entryname of enabled bootload directory regardless of */
/* the current DMS state (i.e., the .init suffix will never be returned. */
/* We do not report any errors from this entry.			   */

   return (GET_BOOTLOAD_DIR_NAME (ENABLED_BOOTLOAD_DIR_NAME));

/* end dm_per_system_$get_enabled_bootload_dirname; */
%skip (4);
dm_per_system_$set_system_state:
   entry (p_new_system_state);

/* We currently trust the new state passed to us.  If desired, error	*/
/* detection may be added at a later date (e.g., incorrect sequence	*/
/* of change, invalid state); however, more definition of the states	*/
/* will probably be necessary before doing so.			*/

/* set the state and return */
   dm_system_data_$current_dm_state = p_new_system_state;

   call RETURN ();

/* end dm_per_system_$set_system_state */
%page;
TRY_DM_SYSTEM_TAKEOVER:
   proc (tdst_p_new_event_channel, tdst_p_old_bootload_directory)
        returns (char (4) aligned);

/* This internal procedure tries to adopt a running DMS.  If it	*/
/* fails, the sub_err_ routine will be called to report the failure.	*/
/* If the DMS for the current Multics bootload has shutdown, no	*/
/* takeover is done and the shutdown status is returned so the Daemon	*/
/* may bring up another DMS.  Also, if the DMS should have shutdown,	*/
/* but has not and the time to bump users and logout the Daemon has	*/
/* past, we: reset the shutdown information, allow new transactions,	*/
/* and set the DMS state to running.  This code used to be in the	*/
/* Daemon overseer, but has been moved here to ease maintenance.	*/

dcl  (
     tdst_p_new_event_channel		fixed bin (71) aligned,
     tdst_p_old_bootload_directory	char (*)
     )				parameter;

dcl  tdst_old_dm_system_data_ptr	ptr init (null) automatic;

   on cleanup call TDST_CLEANUP ();

   call hcs_$initiate (tdst_p_old_bootload_directory, SYS_SEG, OLD_SYS_SEG, 0,
        0, tdst_old_dm_system_data_ptr, code);
   if code ^= 0 | tdst_old_dm_system_data_ptr = null () then
      call ERROR_RETURN (code,
	 "Unable to initiate the system data segment ^a with the reference name ^a, in the old DM system directory ^a.",
	 SYS_SEG, OLD_SYS_SEG, tdst_p_old_bootload_directory);

   call hcs_$validate_processid (old_dm_system_data_$initializer_processid,
        code);
   if code = 0 then					/* we have a current caretaker */
      call ERROR_RETURN (0,
	 "Current DM system ^a already has caretaker Daemon ^a (pid ^w).",
	 tdst_p_old_bootload_directory, old_dm_system_data_$initializer_name,
	 old_dm_system_data_$initializer_processid);


   if old_dm_system_data_$current_dm_state ^= DM_SYSTEM_STATE_RUNNING
        & old_dm_system_data_$current_dm_state
        ^= DM_SYSTEM_STATE_SHUTDOWN_BEGUN
        & old_dm_system_data_$current_dm_state
        ^= DM_SYSTEM_STATE_SHUTDOWN_BUMP_USERS then
NO_DMS_TO_TAKEOVER:
      do;
      if old_dm_system_data_$current_dm_state = DM_SYSTEM_STATE_NORMAL_SHUTDOWN
	 then
MAY_BOOT_AFTER_NORMAL_SHUT:				/* recovery will take care of boot dir */
         return (DM_SYSTEM_STATE_NORMAL_SHUTDOWN);

      else					/* should not happen, arbitrary damage */
	 call ERROR_RETURN (dm_error_$per_system_not_init,/* need human intervention */
	      "Unable to takeover non-running DMS, state: ^a, bootload dir: ^a.",
	      (old_dm_system_data_$current_dm_state),
	      tdst_p_old_bootload_directory);
   end NO_DMS_TO_TAKEOVER;

   if dm_system_config.adopt = DM_DO_NOT_ADOPT_OLD_BOOTLOAD then
      call ERROR_RETURN (0,
	 "Configuration file disallows takeover of running DM system ^a.",
	 tdst_p_old_bootload_directory);

/* If we get to this point, we must try to take over the current running DM */
/* system's per-bootload directory */

   call hcs_$initiate (tdst_p_old_bootload_directory, SYS_SEG, SYS_SEG, 0, 0,
        null (), code);
   if code ^= 0 & code ^= error_table_$segknown then
      call ERROR_RETURN (code,
	 "Unable to initiate the system data segment ^a with the reference name ^a, in the old DM system directory ^a.  Attempted takeover of running system failed.",
	 SYS_SEG, SYS_SEG, tdst_p_old_bootload_directory);

   call dm_misc_util_$log (LOG_SV, "");			/* dummy to get a blank line */
   call dm_misc_util_$log (LOG_SV,
        "STARTING TAKEOVER of DM system ^a by process ^a (pid = ^w), from ^a (pid = ^w).",
        tdst_p_old_bootload_directory, get_group_id_$tag_star (),
        get_process_id_ (), dm_system_data_$initializer_name,
        dm_system_data_$initializer_processid);

RESET_SHUTDOWN_INFO:
   do;

/* Any takeover resets the admin and active shutdown data, makes sure	*/
/* transactions may be started, and sets the system state to running.	*/
/* The login ring module is responsible for always scheduling a DMS	*/
/* shutdown based on the Multics shutdown time.			*/

      dm_system_data_$current_dm_state = DM_SYSTEM_STATE_RUNNING;
      if dm_system_data_$saved_begin_shutdown_time ^= 0 then do;
         dm_system_data_$saved_user_warning_time,
	    dm_system_data_$saved_begin_shutdown_time,
	    dm_system_data_$saved_user_shutdown_time,
	    dm_system_data_$saved_user_bump_time,
	    dm_system_data_$saved_daemon_logout_time = 0; /* calc from Mutlics shut time */
         dm_system_data_$saved_shutdown_reason =
	    "NO REASON FOR SHUTDOWN GIVEN";		/* same as in dm_system_data_template_ */
         call dm_misc_util_$log (LOG_SV,
	    "Previous admin shutdown infomration reset during takeover of DM."
	    );
      end;

      call transaction_manager_$begins_on ();		/* make sure users can get in */
   end RESET_SHUTDOWN_INFO;

   dm_system_data_$initializer_event_chn = tdst_p_new_event_channel;
   dm_system_data_$initializer_name = get_group_id_$tag_star ();
   dm_system_data_$initializer_processid = get_process_id_ ();
						/* we now "own" it */

   call dm_misc_util_$log (LOG_SV, "Finished takeover of DM system.");

   call term_$single_refname ((OLD_SYS_SEG), (0));

   return (DM_SYSTEM_STATE_RUNNING);			/* This indicates successful takeover. Actual state may be one of the shutdown states. */

TDST_CLEANUP:
   proc ();

   if tdst_old_dm_system_data_ptr ^= null () then
      call term_$seg_ptr (tdst_old_dm_system_data_ptr, (0));

   end TDST_CLEANUP;

   end TRY_DM_SYSTEM_TAKEOVER;
%page;
GET_BOOTLOAD_DIR_NAME:
   proc (gbdn_p_is_process_initializing_dms) returns (char (32));

/*  Internal Procedure to generate the name of the per-bootload directory  */
/*  It accepts one input argument to decide if it should return the name of */
/*  the directory before or after the DMS system has been enabled */
/*  The name is based on the Multics bootload time after running it through */
/*  the request_id_ subr. and truncating the time to the minute.  This */
/*  allows the use of the construct "cwd {aim_dir}>[substr [request_id */
/*  [system date_time_last_up]] 1 10]" from command level and helps prevent */
/*  multiple DMS's running at the same AIM level. */

dcl  gbdn_p_is_process_initializing_dms bit (1) aligned parameter;

dcl  gbdn_time_of_multics_bootload	fixed bin (71) automatic;

/* fill in the internal static that will give the base of all naming of */
/* any per-bootload directory. */
   if multics_bootload_request_id_str = "" then do;
      call system_info_$timeup (gbdn_time_of_multics_bootload);
      multics_bootload_request_id_str =
	 "dm_dir."
	 || substr (request_id_ (gbdn_time_of_multics_bootload), 1, 10);
   end;

   if gbdn_p_is_process_initializing_dms then
      return (multics_bootload_request_id_str || ".init");
   else return (multics_bootload_request_id_str);

   end GET_BOOTLOAD_DIR_NAME;
%page;
RESET_VALIDATION_LEVEL:
   proc ();

   call cu_$level_set (level);

   return;

   end RESET_VALIDATION_LEVEL;
%skip (4);
CLEAN_UP_INIT:
   proc ();

/*  Internal Procedure to clean up for $init entry only.

 - delete dm_system_data_ if created
 - delete the per-bootload directory if created
*/

dcl  cui_initialization_bootload_dir	char (168) automatic;

   if dm_system_copyp ^= null () then do;
      call delete_$ptr (dm_system_copyp, "000100"b, "", 0);
      dm_system_copyp = null ();
   end;

   if dms_initializer_process then do;			/* must delete the init dir if created */
      cui_initialization_bootload_dir =
	 GET_BOOTLOAD_DIR_NAME (INITIALIZATION_BOOTLOAD_DIR_NAME);
      call delete_$path (aim_dir, cui_initialization_bootload_dir, "001000"b,
	 "", 0);
      dms_initializer_process = "0"b;
   end;

   call FINISH_INIT (UNLOCK_CONFIG);

   return;

   end CLEAN_UP_INIT;
%page;
FINISH_INIT:
   proc (fi_p_config_lock_action);
dcl  fi_p_config_lock_action		bit (1) aligned parameter;

   if fi_p_config_lock_action = UNLOCK_CONFIG then
      if dm_system_config_ptr ^= null () then do;
         on sub_error_ go to FI_TERM_CONFIG;
         call dm_lock_configuration_$unlock (dm_system_config_ptr);
FI_TERM_CONFIG:
         on sub_error_ go to FI_CANT_TERM_CONFIG;
         call dm_find_configuration_$terminate (dm_system_config_ptr);
FI_CANT_TERM_CONFIG:
         revert sub_error_;
      end;

   call RESET_VALIDATION_LEVEL ();

   return;

   end FINISH_INIT;
%skip (4);
RETURN:
   proc ();					/* common return procedure for ease of debugging by needing only one break */

   go to MAIN_RETURN;

   end RETURN;
%skip (4);
MAIN_RETURN:
   return;
%page;
ERROR_RETURN:
   proc options (variable);

dcl  (
     er_arg_list_ptr		ptr,
     er_code			fixed bin (35),
     er_message			char (1024),
     er_message_length		fixed bin (21)
     )				automatic;

dcl  (
     er_fixed_bin_35_value		fixed bin (35),
     er_message_overlay		char (er_message_length)
     )				based;

   call cu_$arg_list_ptr (er_arg_list_ptr);
   er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_fixed_bin_35_value;

   call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message, er_message_length,
        IOA_GENERAL_RS_DONT_PAD, IOA_GENERAL_RS_NO_NEW_LINE);
   call sub_err_ (er_code, MYNAME, ACTION_CANT_RESTART, null (), 0,
        "By entry ^a:  ^a", entrypoint_name,
        addr (er_message) -> er_message_overlay);

   end ERROR_RETURN;
%skip (4);
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

dcl  cv_p_received_version		char (8) aligned;
dcl  cv_p_expected_version		char (8) aligned;
dcl  cv_p_structure_name		char (*);

   if cv_p_received_version ^= cv_p_expected_version then
      call ERROR_RETURN (error_table_$unimplemented_version,
	 "^/Expected version ^d of the ^a structure.^/Received version ^d, instead.",
	 cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include access_mode_values;
%page;
%include area_info;
%page;
%include dm_log_sv_codes;
%page;
%include dm_system_states;
%page;
%include dm_system_config;
%page;
%include arg_list;
%page;
%include sub_err_flags;


   end dm_per_system_$init;




		    dm_recovery_.pl1                04/04/85  1114.9re  04/04/85  0824.6      203580



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

/*  DESCRIPTION:

	This is the program that does all crash recovery work.  It looks at
     the configuration file for bootload indicators and has two main parts:
     check to see if recovery is necessary or can be done at all, and the
     actual rollback of uncompleted transactions.  This program should only
     be called by dm_initializer_ from within the DM Daemon at initialization
     time for a particular AIM level.

	The first is responsible for making sure there is a previous set of
     DM tables to possibly recover from.  Any of three things missing can make
     recovery impossible: the previous per-bootload directory is missing, the
     file manager's UID to pathname table is missing, or the before journal
     manager's UID to pathname table is missing.  If we find a dm_system_data_
     in the old directory with the normal shutdown indicator set properly,
     recovery need not be done and we return.

	The rollback after crash is the second part of recovery.  It opens
     the before journals recorded in the old bootload BJM UID-pathname table,
     finds the ends of these journals, and creates a list of transactions
     that have not been committed or aborted.  These transactions are then
     rolled back using the normal methods with some minor modifications of
     the Daemon adoption/abandon scheme.  If any before journal or
     synchronized file cannot be found, an error is registered in the Data
     Management log.  Any errors found during recovery will be logged in the
     above log using dm_misc_util_$log, but this program and its subordinates
     will not print the error on the console.  If dm_recovery_ finds a fatal
     error, or if non-fatal recovery errors are not allowed (expected to be 
     the normal case), sub_err_ will be called at the end of all work to abort
     further DMS initialization.  This keeps msgs. for the System administrator
     from confusing the operator.

/* DESCRIPTION CONTINUED NEXT PAGE */

/* DESCRIPTION CONTINUED FROM PREVIOUS PAGE */
/*

	Note that two changes will have to be made to this recovery
     procedure when some parts of DM are implemented that are not being done
     now.  The first is before journal and after journal phasing.  The other
     is multi-phase commits, which are only partially handled currently.
*/

/*  HISTORY:

Written by Lee A. Newcomb, 11/01/82.
Modified:
01/13/83 by L. A. Newcomb: add call to file_manager_$end_of_crash_recovery.
03/01/83 by L. A. Newcomb: to use dm_log_sv_codes include and fix up
	  the program to reference correctly the modified bj_txt structure.
03/27/83 by L. A. Newcomb: log how many journals were opened for
	  crash recovery.  Should be a temp. mod.
03/29/83 by L. A. Newcomb: correct a typo in a log msg., report when some BJ's
	  could not be opened for recovery, and how many were opened.
04/07/83 by L. A. Newcomb:  added call to bjm_$close_bj_after_recovery if an
            error occurred recovering the txns in a journal so it cannot be
            used.
05/18/83 by Lindsey L. Spratt:  Changed to use version 3 of the TDT.
06/07/83 by L. A. Newcomb:  fixed to handle all recovery tasks and use the
	  configuration file for deciding if we do recovery, what to do with
	  the old bootload dir, and whether or not to die on non-fatal
	  recovery errors.
06/13/83 by L. A. Newcomb:  fixed problem where old bootload directories from
            the same Multics bootload would cause holding of the current
            recovered dir.  to fail.
08/14/83 by L. A. Newcomb:  fixed some calls to dm_log_ to be information type
            instead of error type.
10/07/83 by L. A. Newcomb:  to terminate old file_manager_ UID to pathname
	  table reference before deleting old bootload directory.
03/05/84 by L. A. Newcomb:  To use the include file dm_system_states (renamed
            from dm_statuses) and the new names therein.
05/29/84 by Lindsey L. Spratt:  Changed to use version 2 of dm_system_config,
            added a version check via CHECK_VERSION.
11/22/84 by Lee A. Newcomb:  Changed to use dm_misc_util_$get_aim_dir.
12/07/84 by R. Michael Tague:  Changed dm_util_$* to dm_misc_util_$*.
02/20/85 by Lee A. Newcomb:  Fixed to reset the validation level before
            returning, and to not lose an error from tm_$recovery_after_crash
            when deciding to increment n_bjs_completely_recovered.  Also
            changed to init automatic vars.
02/26/85 by Lee A. Newcomb:  Fixed to understand
            dm_error_$too_many_bootload_dirs is a fatal error.
03/05/85 by Steve Herbst: Replaced dm_log_ with dm_misc_util_$log.
03/18/85 by Steve Herbst: Fixed format of "ENTERING" log message.
*/
/* format:  style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */
%page;
dm_recovery_: proc ();

/* START OF DECLARATIONS */

/* Parameter */

/* Automatic */
dcl  (
     aim_dir		        char (168) init (""),
     bj_oid_p		        ptr init (null),	/* location of vector of bj_oid's */
     bj_uid_p		        ptr init (null),	/* location of vector of bj_uid's */
     check_mode		        bit (1) aligned init (""b), /* how extensivly examine BJ's? */
     code			        fixed bin (35) init (0), /* normal error code */
     do_not_force_enable	        bit (1) aligned init (""b), /* def: die no fatal errors */
     idx			        fixed bin init (0),	/* loop index */
     n_bjs_completely_recovered       fixed bin init (0),	/* how many BJ's were recovered with no errors */
     n_bjs_opened_for_recovery        fixed bin init (0),	/* how many BJ's could be opened for crash recovery */
     n_hold_dirs		        fixed bin init (0),	/* how many old bootload dirs exist */
     no_recovery_needed	        bit (1) aligned init (""b), /* def: recover unless told otherwise */
     old_bj_txt_p		        ptr init (null),
     old_boot_dir		        char (168) init (""), /* last dm_dir.BOOTLOAD dir in DM_AIM_dir */
     old_boot_dir_name	        char (32) init (""),	/* entryname of old_boot_dir for deleting */
     old_dm_status		        char (4) aligned init (""), /* state of last bootload instance */
     old_tm_tdt_p		        ptr init (null),
     saved_dm_state		        char (4) aligned init (""),
     saved_level		        fixed bin init (-1)	/* validation level at entry */
     )			        automatic;

/* Based */
dcl  (						/* temp. vectors for recovery */
     bj_oid		        based (bj_oid_p),
     bj_uid		        based (bj_uid_p)
     )			        bit (36) aligned dim (1:n_bjs_opened_for_recovery);

/* Builtin */
dcl
     (char, null, ltrim,
     rtrim, unspec)		        builtin;

/* Condition */
dcl  cleanup		        condition;

/* Constant */
dcl
     MYNAME		        char (12) init ("dm_recovery_")
			        internal static options (constant);
						/* Entry */
dcl  (
     before_journal_manager_$close_bj entry (bit (36) aligned, fixed bin (35)),
     before_journal_manager_$close_bj_after_recovery
			        entry (bit (36) aligned, fixed bin (35)),
     before_journal_manager_$find_txns_after_crash
			        entry (ptr, ptr, bit (36) aligned, bit (1) aligned, fixed bin (35)),
     before_journal_manager_$open_all_after_crash
			        entry (char (*), ptr, ptr, fixed bin, fixed bin (35)),
     cu_$level_get		        entry (fixed bin),
     cu_$level_set		        entry (fixed bin),
     delete_$path		        entry (char (*), char (*), bit (6), char (*), fixed bin (35)),
     dm_find_configuration_	        entry () returns (ptr),
     dm_misc_util_$log	        entry options (variable),
     dm_misc_util_$get_aim_dir        entry (char (*)),
     dm_misc_util_$dm_status	        entry (char (*), char (4) aligned, fixed bin (35)),
     dm_misc_util_$find_old_boot_dir  entry (char (*), char (*), fixed bin (35)),
     expand_pathname_	        entry (char (*), char (*), char (*), fixed bin (35)),
     file_manager_$end_of_crash_recovery
			        entry (fixed bin (35)),
     file_manager_$find_old_uid_pn_table
			        entry (char (*), fixed bin (35)),
     get_ring_		        entry () returns (fixed bin (3)),
     get_temp_segment_	        entry (char (*), ptr, fixed bin (35)),
     hcs_$chname_file	        entry (char (*), char (*), char (*), char (*), fixed bin (35)),
     hcs_$star_		        entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
     release_temp_segment_	        entry (char (*), ptr, fixed bin (35)),
     sub_err_		        entry () options (variable),
     transaction_manager_$recover_after_crash
			        entry (ptr, ptr, fixed bin (35))
     )			        external;

/* External */
dcl  (
     dm_error_$bj_not_all_opened_after_crash fixed bin (35),
     dm_error_$partial_recovery       fixed bin (35),
     dm_error_$too_many_bootload_dirs fixed bin (35),
     dm_system_data_$current_dm_state char (4) aligned,
     error_table_$nomatch	        fixed bin (35),
     error_table_$unimplemented_version fixed bin (35)
     )			        external static;

/* Static */

/* END OF DECLARATIONS */
%page;
SET_LEVEL_AND_CLEANUP_HANDLER:
	do;

	     call cu_$level_get (saved_level);

	     on cleanup begin;
		call CLEAN_UP ("0"b /* we are unwinding, don't call sub_err_ */);
		call cu_$level_set (saved_level);
	     end;

	     call cu_$level_set (get_ring_ ());

	end SET_LEVEL_AND_CLEANUP_HANDLER;

FIND_CONFIG_FILE:
	dm_system_config_ptr = dm_find_configuration_ ();

	call CHECK_VERSION (dm_system_config.version, DM_CONFIG_VERSION_2, "dm_system_config");

	call dm_misc_util_$log (LOG_SV, "ENTERING system crash recovery code.");
%page;
FIND_DIRS_AND_SET_INDICATORS:
	do;

	     call dm_misc_util_$get_aim_dir (aim_dir);

	     saved_dm_state = dm_system_data_$current_dm_state; /* save state for reset if success */
	     dm_system_data_$current_dm_state = DM_SYSTEM_STATE_RECOVERING;

/* must we die on "non-fatal" recovery errors? */
	     do_not_force_enable = (dm_system_config.curr_dm_enable = DM_DO_NOT_FORCE_ENABLE_NEW_BOOTLOAD);

/* how extensive before journal examination? */
	     check_mode = (dm_system_config.recovery_check_mode = DM_RECOVERY_CHECK_MODE_ON);

	end FIND_DIRS_AND_SET_INDICATORS;

FIND_OLD_BOOTLOAD_TO_RECOVER:
	do;

	     call dm_misc_util_$find_old_boot_dir (aim_dir, old_boot_dir, code);
	     if code = dm_error_$too_many_bootload_dirs then /* fatal error */
		call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null, 0, "Per-AIM directory is ^a.", aim_dir);
	     else if code ^= 0 then do;
		call dm_misc_util_$log (LOG_SV, code, MYNAME,
		     "No old bootload directory to recover in ^a.", aim_dir);
						/* EXTRA CODE MUST BE ADDED HERE TO */
						/* DETECT LOST BOOTLOADS IF RECOVERY ENABLED */
		go to RESET_DM_STATE;
	     end;
	     else
CHECK_IF_TO_IGNORE_RECOVERY:
		if dm_system_config.recover = DM_DO_NOT_RECOVER_OLD_BOOTLOAD then do;
		call dm_misc_util_$log (LOG_SV,
		     "WARNING: recovery has been disabled by administrator; will not recover ^a.",
		     rtrim (old_boot_dir));
		no_recovery_needed = "1"b;
		go to RECOVERY_CLEANUP_CHORES;	/* we still must do this part */
	     end;
	     else call dm_misc_util_$log (LOG_SV, "^5xDirectory to recover:^2x^a.", rtrim (old_boot_dir));

	     call dm_misc_util_$dm_status (old_boot_dir, old_dm_status, code);
	     if code = 0 then			/* have a good dm_system_data_ left */
		if old_dm_status = DM_SYSTEM_STATE_NORMAL_SHUTDOWN then do; /* nothing to recover */
		     call dm_misc_util_$log (LOG_SV, "No recovery required, no errors in previous DMS shutdown.");
		     no_recovery_needed = "1"b;
		     go to RECOVERY_CLEANUP_CHORES;
		end;

	end FIND_OLD_BOOTLOAD_TO_RECOVER;		/* ok, we need to do recovery */
%page;
GET_FM_UID_PATHNAME_TABLE:

	call file_manager_$find_old_uid_pn_table (old_boot_dir, code);
	if code ^= 0 then do;
	     call dm_misc_util_$log (LOG_SV, code, MYNAME, "No old file manager pathname-UID table.");
	     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
		"No old file manager path-UID table to use for recovery in ^a.", old_boot_dir);
	end;

GET_TEMP_STORAGE:
	do;

	     call get_temp_segment_ (MYNAME, bj_oid_p, code);
	     if code ^= 0 then
		call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
		     "Unable to get temp. storage for BJ OID's.");

	     call get_temp_segment_ (MYNAME, bj_uid_p, code);
	     if code ^= 0 then
		call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
		     "Unable to get temp. storage for BJ UID's.");

	     call get_temp_segment_ (MYNAME, old_bj_txt_p, code);
	     if code ^= 0 then
		call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
		     "Unable to get temp. storage for txn list building.");

	     call get_temp_segment_ (MYNAME, old_tm_tdt_p, code);
	     if code ^= 0 then
		call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
		     "Unable to get temp. storage for txn list building.");


	end GET_TEMP_STORAGE;
%page;
FIND_JOURNALS_TO_RECOVER:
	do;

/* Now find the before journals to be used in recovery. */
/*     We initialize the cell n_bjs_completely_recovered which will be used */
/*     to detect partial or complete recovery.  Every time we recovery using */
/*     a journal with no errors, we add one to this cell.  If a code of one */
/*     is returned from the call to open the BJ's, we set the cell to -1 so */
/*     we will always see partial recovery. */

	     call before_journal_manager_$open_all_after_crash (old_boot_dir,
		bj_oid_p, bj_uid_p, n_bjs_opened_for_recovery, code);

	     if code = dm_error_$bj_not_all_opened_after_crash then do; /* some BJ's could not be opened */
		n_bjs_completely_recovered = -1;	/* make sure we report partial recovery */
		call dm_misc_util_$log (LOG_SV, code, MYNAME);
	     end;
	     else if code ^= 0 then			/* FATAL -> could not open any BJ's */
		call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0, /* consider it a fatal recovery error */
		     "Unable to open before journals open at crash time.");

	     call dm_misc_util_$log (LOG_SV, "Number of journals opened for crash recovery = ^d.", n_bjs_opened_for_recovery);

	end FIND_JOURNALS_TO_RECOVER;
%page;
/***** IF CONTROL GETS HERE, WE HAVE TO DO CRASH RECOVERY *****/

RECOVER_EACH_JOURNAL_LOOP:
	do idx = 1 to n_bjs_opened_for_recovery;

/* step:  create a temporary transaction list of the old txns not finished */
/*     at crash time, initially empty.  This currently consists of two */
/*     temporary segments corresponding to the transaction and before */
/*     journal managers' transaction tables.  These tables must be */
/*     logically empty before processing each before journal. */

	     old_tm_tdt_p -> tm_tdt.entry_count = 0;
	     unspec (old_tm_tdt_p -> tm_tdt) = ""b;
	     old_tm_tdt_p -> tm_tdt.version = TM_TDT_VERSION_3;
	     old_bj_txt_p -> bj_txt.version = BJ_TXT_VERSION_1;
	     old_bj_txt_p -> bj_txt.n_entries_used,
		old_bj_txt_p -> bj_txt.max_n_entries = 0;
	     old_bj_txt_p -> bj_txt.pad_entry_to_32_words = ""b;

/* step:  find unfinished transactions in the BJ and add them to the */
/*     temporary transaction table(s) for processing later */

	     call before_journal_manager_$find_txns_after_crash (
		old_tm_tdt_p, old_bj_txt_p, bj_oid (idx), check_mode, code);
	     if code ^= 0 then do;
		call dm_misc_util_$log (LOG_SV, code, MYNAME,
		     "Unable to list unfinished txns. in BJ, OID = ^o.", bj_oid (idx));
		go to SKIP_BEFORE_JOURNAL;
	     end;
	     old_bj_txt_p -> bj_txt.entry.bj_uid = bj_uid (idx); /* must patch in for rollback */

/* step:  pass the temp. tables to transaction_manager_ to finish any */
/*     processing needed on the txns found. */

	     call transaction_manager_$recover_after_crash (
		old_tm_tdt_p, old_bj_txt_p, code);	/* code checked in next step */

/* step:  we may now close the journal.  This will be done normally if no */
/*     errors occurred in recovering the txns in the journal.  Otherwise, */
/*     we note the journal had unrecoverable txns for later observation. */

SKIP_BEFORE_JOURNAL:
	     if code = 0 then do;
		call before_journal_manager_$close_bj (bj_oid (idx), code);
						/* no errors at all, record for partial vs. */
						/* complete recovery
decision */
		if code = 0 then
		     n_bjs_completely_recovered = n_bjs_completely_recovered + 1;
	     end;
	     else call before_journal_manager_$close_bj_after_recovery (bj_oid (idx), code);
	     if code ^= 0 then			/* oh, well... */
		call dm_misc_util_$log (LOG_SV, code, MYNAME, "Unable to close BJ, OID ^o.", bj_oid (idx));

	end RECOVER_EACH_JOURNAL_LOOP;
%page;
RECOVERY_CLEANUP_CHORES:				/* we always come here except when we die */

REPORT_JOURNALS_NOT_RECOVERED:
	if ^no_recovery_needed then do;		/* did try recovery */
	     if n_bjs_completely_recovered ^= n_bjs_opened_for_recovery then
		if do_not_force_enable then		/* must die here */
		     call sub_err_ (dm_error_$partial_recovery, MYNAME, ACTION_CANT_RESTART, null (), 0,
			"Trying to recover ^a.", old_boot_dir);
		else call dm_misc_util_$log (LOG_SV, dm_error_$partial_recovery, MYNAME,
			"Trying to recover ^a.", old_boot_dir);
	end;

FILE_MANAGER_CLEANUP_CHORE:
	if ^no_recovery_needed then do;		/* file_mamanger_ knows some things */
	     call file_manager_$end_of_crash_recovery (code);
	     if code ^= 0 then
		call dm_misc_util_$log (LOG_SV, code, MYNAME,
		     "Unable to terminate file_manager_'s ref. to old bootload tables.");
	end;
%page;
OLD_BOOTLOAD_DIR_DISPOSITION:
	do;

	     call expand_pathname_ (old_boot_dir, (aim_dir), old_boot_dir_name, code);
	     if code ^= 0 then			/* fatal? */
		if do_not_force_enable then		/*  yes */
		     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			"Could not expand old bootload dir pathname ^a.", old_boot_dir);
		else call dm_misc_util_$log (LOG_SV, code, MYNAME,
			"Could not expand old bootload dir pathname ^a.", old_boot_dir);

	     if dm_system_config.hold = DM_HOLD_OLD_BOOTLOAD_DIRECTORY then do;
						/* do any .hold.*'s already exist? */
		call hcs_$star_ (aim_dir, rtrim (old_boot_dir_name) || ".hold.*", star_BRANCHES_ONLY,
		     null (), n_hold_dirs, (null ()), (null ()), code);
		if code ^= 0 & code ^= error_table_$nomatch then
		     if do_not_force_enable then
			call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			     "Cannot find out the current # of .hold.* direcotries in ^a.", aim_dir);
		     else call dm_misc_util_$log (LOG_SV, code, MYNAME,
			     "Cannot find out the current # of .hold.* directories in ^a.", aim_dir);

		else do;				/* get hold tag and rename */
		     call hcs_$chname_file (aim_dir, old_boot_dir_name, old_boot_dir_name,
			rtrim (old_boot_dir_name) || ".hold." || ltrim (rtrim (char (n_hold_dirs + 1))), code);
		     if code ^= 0 then		/* see if we can allow this */
			if do_not_force_enable then
			     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
				"Cannot rename old bootload directory ^a.", old_boot_dir);
			else call dm_misc_util_$log (LOG_SV, code, MYNAME,
				"Cannot rename old bootload directory ^a.", old_boot_dir);
		end;
	     end;
	     else do;				/* must delete */
		call delete_$path (aim_dir, old_boot_dir_name, "101000"b, MYNAME, code);
		if code ^= 0 then			/* fatal? */
		     if do_not_force_enable then	/*  yes */
			call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			     "Could not delete old bootload direcotry ^a.", old_boot_dir);
		     else call dm_misc_util_$log (LOG_SV, code, MYNAME,
			     "Could not delete old bootload direcotry ^a.", old_boot_dir);
	     end;

	     if no_recovery_needed then
		go to RESET_DM_STATE;

	end OLD_BOOTLOAD_DIR_DISPOSITION;
%page;
NORMAL_TERMINATION_CLEANUP:

	call CLEAN_UP ("1"b /* report clean_up errors */);
	call cu_$level_set (saved_level);

RESET_DM_STATE:
	dm_system_data_$current_dm_state = saved_dm_state;

	call dm_misc_util_$log (LOG_SV, "FINISHED recovery^[ of ^a^].",
	     (old_boot_dir ^= ""), old_boot_dir);

	return;
%page;
CLEAN_UP:
     proc (report_error_sw);

/* This procedure releases the temporary segments acquired for recovery.   */
/* If report_error_sw is on, it means that the call is after a successful  */
/* recovery (or at least one where non-fatal errors are allowed).  Any     */
/* error in this program when the parameter switch is on is considered a   */
/* fatal recovery error. */

dcl
     report_error_sw	        bit (1) aligned
			        parameter;

dcl
     cleanup_code		        fixed bin (35)
			        automatic;

	if bj_oid_p ^= null () then do;
	     call release_temp_segment_ (MYNAME, bj_oid_p, cleanup_code);
	     if cleanup_code ^= 0 then
		if report_error_sw then
		     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			"Unable to release temp. storage for BJ OID's.");
	end;

	if bj_uid_p ^= null () then do;
	     call release_temp_segment_ (MYNAME, bj_uid_p, cleanup_code);
	     if cleanup_code ^= 0 then
		if report_error_sw then
		     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			"Unable to release temp. storage for BJ UID's.");
	end;

	if old_tm_tdt_p ^= null () then do;
	     call release_temp_segment_ (MYNAME, old_tm_tdt_p, cleanup_code);
	     if cleanup_code ^= 0 then
		if report_error_sw then
		     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			"Unable to release temp. txn. lists.");
	end;

	if old_bj_txt_p ^= null () then do;
	     call release_temp_segment_ (MYNAME, old_bj_txt_p, cleanup_code);
	     if cleanup_code ^= 0 then
		if report_error_sw then
		     call sub_err_ (code, MYNAME, ACTION_CANT_RESTART, null (), 0,
			"Unable to release temp. txn. lists.");
	end;

     end CLEAN_UP;
%page;
CHECK_VERSION:
     proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

dcl  cv_p_received_version	        char (8) aligned;
dcl  cv_p_expected_version	        char (8) aligned;
dcl  cv_p_structure_name	        char (*);

	if cv_p_received_version ^= cv_p_expected_version
	     then call
		sub_err_ (error_table_$unimplemented_version, MYNAME, ACTION_CANT_RESTART, null, 0,
		"^/Expected version ^d of the ^a structure.
Received version ^d, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

     end CHECK_VERSION;
%page;
%include dm_bj_txt;
%page;
%include dm_tm_tdt;
%page;
%include dm_system_config;
%page;
%include dm_system_states;
%page;
%include dm_log_sv_codes;
%page;
%include star_structures;
%page;
%include sub_err_flags;


     end dm_recovery_;




		    dm_request_action_.cds          03/06/85  0751.0re  03/05/85  0755.9       33147



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

/* DESCRIPTION:

   This is is the system wide table of requests that can be used to signal
   the  DMS  caretaker  Daemon.   The values of actions are sparse to enable
   grouping  of  similar  functions;  as  a new function is added, it can be
   conceptually placed with other actions of the same type.
*/

/* HISTORY:
   Written by Mike Pandolf, 10/28/82.
   Modified:
   11/04/82 by M. Pandolf:  to add bury_dead_process action.
   11/19/82 by M. Pandolf:  to add new_proc action.
   01/25/83 by M. Pandolf:  to add adjust_tdt_entry action and
   to rename bury to adjust_process_id.
   03/11/83 by M. Pandolf:  to add group VI actions.
   06/07/83 by M. Pandolf:  to add flush_journals.
   07/26/83 by M. Pandolf:  to add process_command.
   09/27/84 by Lee A. Newcomb:  added new_process_notificaitons and used DMS
   standard format.
   12/05/84 by R. Michael Tague: removed noop, flush_journals, list_ref_names,
   terminate_segno, and process_command.
   01/22/85 by R. Michael Tague: Added kill_txn.
*/

/* format: style5 */
dm_request_action_:
        procedure ();

/* START OF DECLARATIONS */

/* Parameter */
/* Automatic */
        dcl     (
	      code		fixed bin (35),
	      1 local_cds_args	aligned like cds_args
	      )			automatic,
	      1 request_actions	aligned automatic,
	        2 (shutdown, new_proc, adjust_tdt, adjust_txn,
		  adjust_tdt_entry, kill_txn, adjust_process_id,
		  new_process_notifications)
				fixed bin (17);

/*  Builtin  */
        dcl     (addr, hbound, size, unspec)
				builtin;

/*  Constant  */
        dcl     (
	      EXCLUDE_ARRAY		(1) char (32) init ("pad*"),
	      MYNAME		char (32) init ("dm_request_action_")
	      )			int static options (constant);

/*  Entry  */
        dcl     (
	      com_err_		entry options (variable),
	      create_data_segment_	entry (ptr, fixed bin (35))
	      );

/* END OF DECLARATIONS */
%page;
/* Group I - system action wakeup types */

        request_actions.shutdown = 102;
        request_actions.new_proc = 103;

/* Group II - transaction specific action wakeup types */

        request_actions.adjust_tdt = 201;
        request_actions.adjust_txn = 202;
        request_actions.adjust_tdt_entry = 203;
        request_actions.kill_txn = 204;

/* Group III - before journal specific action wakeup types */

/* Group IV - data management file specific action wakeup types */

/* Group V - general process cleanup & new process interfaces */

        request_actions.adjust_process_id = 501;
        request_actions.new_process_notifications = 502;

/* Group VI - special wakeup types */

/* Initialize cds structure */

        unspec (local_cds_args) = ""b;

        local_cds_args.sections (1).p = addr (request_actions);
        local_cds_args.sections (1).len = size (request_actions);
        local_cds_args.sections (1).struct_name = "request_actions";
        local_cds_args.seg_name = MYNAME;
        local_cds_args.exclude_array_ptr = addr (EXCLUDE_ARRAY);
        local_cds_args.num_exclude_names = hbound (EXCLUDE_ARRAY, 1);
        local_cds_args.switches.have_text = "1"b;

/* Call CDS to make the segment */

        call create_data_segment_ (addr (local_cds_args), code);
        if code ^= 0 then
	      call com_err_ (code, MYNAME);

        return;

/* end of dm_request_action_; */
%page;
%include cds_args;


        end dm_request_action_;




		    dm_send_request.pl1             04/04/85  1114.9re  04/04/85  0824.8      122832



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

/* DESCRIPTION:
dm_send_request provides a mechanism for Data Management administrators to
send DM Daemon requests over the DM Daemon's request channel.  These requests
are internal requests used by the DM system and usually originate from ring 2
DM code.  Probably the most useful request for a DM administrator is the kill
request.  This request clears the Transaction Definition Table of a specified 
transaction without rolling back or commiting the transaction.
*/

/* HISTORY:

Written by R. Michael Tague, 01/21/85.
Modified:
02/14/85 by R. Michael Tague:  Added a copyright notice, a description, and
            declared a few builtins.
03/19/85 by R. Michael Tague:  Changed to use keyword instead of control 
	  arguments as ammended by the MCR board.
*/

/* format: style5,^indcomtxt */
%page;
dm_send_request:
        proc ();

/* START OF DECLARATIONS */
/* Automatic */

        dcl     accept_keyword_argument bit (1) aligned init ("0"b);
        dcl     arg_idx		fixed bin;
        dcl     arg_len		fixed bin (21);
        dcl     arg_list_ptr		ptr init (null);
        dcl     arg_ptr		ptr;
        dcl     code		fixed bin (35);
        dcl     keyword_argument_idx	fixed bin;
        dcl     force_interpretation_as_argument
				bit (1) aligned init (NO);
        dcl     is_active_function	bit (1) aligned init (NO);
        dcl     number_of_args	fixed bin;
        dcl     return_arg_len	fixed bin (21) init (0);
        dcl     return_arg_ptr	ptr init (null);
        dcl     sci_ptr		ptr init (null);
        dcl     this_is_a_standalone_invocation
				bit (1) aligned init (YES);

        dcl     operation_index	fixed bin init (-1);
        dcl     tdt_index		fixed bin init (0);
        dcl     transaction_id_fixed_bin_36
				fixed bin (36) init (0);

/* Based */

        dcl     arg			char (arg_len) based (arg_ptr);
        dcl     1 transaction_id	based (
				addr (transaction_id_fixed_bin_36)),
	        2 pad		bit (36) aligned,
	        2 transaction_id_bit_36
				bit (36) aligned;
					      /* Builtin */

        dcl     (addr, bin, hbound, index, null, substr)
				builtin;
        dcl     (cleanup, conversion, size)
				condition;

/* Constant */

        dcl     (
	      YES			init ("1"b),
	      NO			init ("0"b)
	      )			bit (1) aligned internal static
				options (constant);
        dcl     myname		init ("dm_send_request")
				char (15) internal static
				options (constant);


        dcl     ARGUMENT_TYPE		(12) internal static
				options (constant) char (64)
				varying
				init ("", "", "tdt index (decimal)",
				"tdt index (decimal)",
				"transaction ID (decimal)",
				"transaction ID (decimal)", "", "", "",
				"", "transaction ID (decimal)",
				"transaction ID (decimal)");
        dcl     KEYWORD_ARGUMENT	(12) internal static
				options (constant) char (64)
				varying
				init ("adjust_tdt", "adjtdt",
				"adjust_tdt_entry", "adjtdte",
				"adjust_txn", "adjtxn", "new_proc",
				"new_process_notifications", "notify",
				"shutdown", "kill_txn", "kill");

        dcl     (
	      ADJUST_TDT		init (1),
	      ADJUST_TDT_ENTRY	init (2),
	      ADJUST_TXN		init (3),
	      NEW_PROC		init (4),
	      NEW_PROCESS_NOTIFICATIONS
				init (5),
	      SHUTDOWN		init (6),
	      KILL_TXN		init (7)
	      )			internal static options (constant)
				fixed bin;


/* Entry */

        dcl     cu_$arg_list_ptr	entry (ptr);
        dcl     cv_dec_check_		entry (char (*), fixed bin (35))
				returns (fixed bin (35));
        dcl     dm_admin_util_$send_adjust_tdt
				entry (fixed bin (35));
        dcl     dm_admin_util_$send_adjust_tdt_entry
				entry (bit (36) aligned, fixed bin,
				fixed bin (35));
        dcl     dm_admin_util_$send_adjust_txn
				entry (bit (36) aligned, fixed bin,
				fixed bin (35));
        dcl     dm_admin_util_$send_new_proc
				entry (fixed bin (35));
        dcl     dm_admin_util_$send_new_process_notifies
				entry (fixed bin (35));
        dcl     dm_admin_util_$send_shutdown
				entry (fixed bin (35));
        dcl     dm_admin_util_$send_kill_txn
				entry (bit (36) aligned, fixed bin (35))
				;
        dcl     ssu_$abort_line	entry () options (variable);
        dcl     ssu_$arg_ptr		entry (ptr, fixed bin, ptr,
				fixed bin (21));
        dcl     ssu_$destroy_invocation entry (ptr);
        dcl     ssu_$return_arg	entry (ptr, fixed bin, bit (1) aligned,
				ptr, fixed bin (21));
        dcl     ssu_$standalone_invocation
				entry (ptr, char (*), char (*), ptr,
				entry, fixed bin (35));

/* External */

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

/* END OF DECLARATIONS */
        call cu_$arg_list_ptr (arg_list_ptr);
        call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr,
	  ABORT_ENTRY, code);

        on cleanup call CLEANUP ();

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

        if is_active_function then
	      call ssu_$abort_line (sci_ptr, error_table_$active_function,
		myname);

        accept_keyword_argument = YES;
        keyword_argument_idx = -1;

        if number_of_args < 1 then
	      call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"^/Usage:  ^a KEYWORD {value}^/Keywords:^/   adjust_tdt, adjtdt^/   adjust_tdt_entry, adjtdte^/   adjust_txn, adjtxn^/   new_proc^/   new_process_notifications, notify^/   shutdown^/   kill_txn, kill",
		myname);
ARG_PROCESSING_LOOP:
        do arg_idx = 1 to number_of_args;
	      call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	      if KEYWORD_ARGUMENT_INDEX (arg) = -1
		| force_interpretation_as_argument = YES then
		    call PROCESS_ARGUMENT (arg, keyword_argument_idx,
		        accept_keyword_argument);
	      else if accept_keyword_argument = YES then
		    call PROCESS_KEYWORD_ARGUMENT (arg,
		        keyword_argument_idx, accept_keyword_argument,
		        force_interpretation_as_argument);
	      else
		    call REPORT_MISSING_ARGUMENT (keyword_argument_idx);
	      if keyword_argument_idx = -1 & accept_keyword_argument = YES
		then
		    goto DO_OPERATION (operation_index);
	      else
		    goto SKIP_OPERATION;

DO_OPERATION (1):				      /* ADJUST_TDT */
	      call dm_admin_util_$send_adjust_tdt (code);
	      goto FINISH_OPERATION;
DO_OPERATION (2):				      /* ADJUST_TDT_ENTRY */
	      call dm_admin_util_$send_adjust_tdt_entry (""b, tdt_index, code)
		;
	      goto FINISH_OPERATION;
DO_OPERATION (3):				      /* ADJUST_TXN */
	      call dm_admin_util_$send_adjust_txn (transaction_id
		.transaction_id_bit_36, 0, code);
	      goto FINISH_OPERATION;
DO_OPERATION (4):				      /* NEW_PROC */
	      call dm_admin_util_$send_new_proc (code);
	      goto FINISH_OPERATION;
DO_OPERATION (5):				      /* NEW_PROCESS_NOTIFICATIONS */
	      call dm_admin_util_$send_new_process_notifies (code);
	      goto FINISH_OPERATION;
DO_OPERATION (6):				      /* SHUTDOWN */
	      call dm_admin_util_$send_shutdown (code);
	      goto FINISH_OPERATION;
DO_OPERATION (7):				      /* KILL_TXN */
	      call dm_admin_util_$send_kill_txn (transaction_id
		.transaction_id_bit_36, code);
	      goto FINISH_OPERATION;
FINISH_OPERATION:
	      if code ^= 0 then
		    call ssu_$abort_line (sci_ptr, code);
SKIP_OPERATION: 
        end ARG_PROCESSING_LOOP;

        if keyword_argument_idx >= 0 & accept_keyword_argument = NO then
	      call REPORT_MISSING_ARGUMENT (keyword_argument_idx);
        call RETURN ();
%page;
MAIN_RETURN:
        return;

RETURN:
        proc ();
        call FINISH ();
        goto MAIN_RETURN;
        end RETURN;

ABORT_ENTRY:
        procedure ();
        call CLEANUP ();
        go to MAIN_RETURN;
        end ABORT_ENTRY;

CLEANUP:
        procedure ();
        call FINISH ();
        end CLEANUP;

FINISH:
        proc ();
        call ssu_$destroy_invocation (sci_ptr);
        end FINISH;

PROCESS_ARGUMENT:
        proc (pa_p_arg, pa_p_keyword_argument_idx, pa_p_accept_keyword_argument)
	  ;

        dcl     pa_p_arg		char (*) parm;
        dcl     pa_p_keyword_argument_idx
				fixed bin parm;
        dcl     pa_p_accept_keyword_argument
				bit (1) aligned parm;

        dcl     pa_code		fixed bin (35);

        pa_code = 0;

        goto ARGUMENT (pa_p_keyword_argument_idx);
ARGUMENT (-1):
        call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
	  "^/The argument ""^a"" is out of place.", arg);
        return;
ARGUMENT (3):				      /* adjust_tdt_entry */
ARGUMENT (4):				      /* adjtdte */
        on size
	      call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"^/Transaction index too large.");
        tdt_index = cv_dec_check_ (arg, pa_code);
        revert size;
        if pa_code ^= 0 then
	      call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"^/Transaction index must be a positive decimal integer.");

        keyword_argument_idx = -1;
        accept_keyword_argument = YES;
        return;

ARGUMENT (5):				      /* adjust_txn */
ARGUMENT (6):				      /* adjtxn */
        on size
	      call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"^/Transaction ID too large.");
        on conversion
	      call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"^/Transaction ID must be positive decimal integer.");
        transaction_id_fixed_bin_36 = bin (arg, 36);
        revert conversion;
        revert size;

        keyword_argument_idx = -1;
        accept_keyword_argument = YES;
        return;

ARGUMENT (11):				      /* kill_txn */
ARGUMENT (12):				      /* kill */
        on size
	      call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"^/Transaction ID too large.");
        on conversion
	      call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		"^/Transaction ID must be positive decimal integer.");
        transaction_id_fixed_bin_36 = bin (arg, 36);
        revert conversion;
        revert size;

        keyword_argument_idx = -1;
        accept_keyword_argument = YES;
        return;

        end PROCESS_ARGUMENT;
%page;
PROCESS_KEYWORD_ARGUMENT:
        proc (pca_p_arg, pca_p_keyword_argument_idx,
	  pca_p_accept_keyword_argument,
	  pca_p_force_interpretation_as_argument);


        dcl     pca_p_arg		char (*) parm;
        dcl     pca_p_keyword_argument_idx
				fixed bin parm;
        dcl     pca_p_accept_keyword_argument
				bit (1) aligned parm;
        dcl     pca_p_force_interpretation_as_argument
				bit (1) aligned parm;

        pca_p_keyword_argument_idx = KEYWORD_ARGUMENT_INDEX (pca_p_arg);
        pca_p_accept_keyword_argument = YES;
        pca_p_force_interpretation_as_argument = NO;

        go to KEYWORD_ARGUMENT (pca_p_keyword_argument_idx);

KEYWORD_ARGUMENT (-1):			      /* not a keyword argument */
        call ssu_$abort_line (sci_ptr, error_table_$bad_arg, pca_p_arg);

KEYWORD_ARGUMENT (1):			      /* adjust_tdt */
KEYWORD_ARGUMENT (2):			      /* adjtdt */
        operation_index = ADJUST_TDT;

        pca_p_keyword_argument_idx = -1;
        pca_p_accept_keyword_argument = YES;
        return;

KEYWORD_ARGUMENT (3):			      /* adjust_tdt_entry */
KEYWORD_ARGUMENT (4):			      /* adjtdte */
        operation_index = ADJUST_TDT_ENTRY;

        pca_p_accept_keyword_argument = NO;
        return;


KEYWORD_ARGUMENT (5):			      /* adjust_txn */
KEYWORD_ARGUMENT (6):			      /* adjtxn */
        operation_index = ADJUST_TXN;

        pca_p_accept_keyword_argument = NO;
        return;


KEYWORD_ARGUMENT (7):			      /* new_proc */
        operation_index = NEW_PROC;

        pca_p_keyword_argument_idx = -1;
        pca_p_accept_keyword_argument = YES;
        return;


KEYWORD_ARGUMENT (8):			      /* new_process_notifications */
KEYWORD_ARGUMENT (9):			      /* notify */
        operation_index = NEW_PROCESS_NOTIFICATIONS;

        pca_p_keyword_argument_idx = -1;
        pca_p_accept_keyword_argument = YES;
        return;


KEYWORD_ARGUMENT (10):			      /* shutdown */
        operation_index = SHUTDOWN;

        pca_p_keyword_argument_idx = -1;
        pca_p_accept_keyword_argument = YES;
        return;


KEYWORD_ARGUMENT (11):			      /* kill_txn */
KEYWORD_ARGUMENT (12):			      /* kill */
        operation_index = KILL_TXN;

        pca_p_accept_keyword_argument = NO;
        return;


        end PROCESS_KEYWORD_ARGUMENT;


KEYWORD_ARGUMENT_INDEX:
        proc (cai_p_arg) returns (fixed bin);

        dcl     cai_p_arg		char (*);
        dcl     cai_keyword_argument_idx
				fixed bin;

        do cai_keyword_argument_idx = 1 to hbound (KEYWORD_ARGUMENT, 1)
	  while (KEYWORD_ARGUMENT (cai_keyword_argument_idx) ^= cai_p_arg);
        end;
        if cai_keyword_argument_idx > hbound (KEYWORD_ARGUMENT, 1) then
	      return (-1);
        else
	      return (cai_keyword_argument_idx);

        end KEYWORD_ARGUMENT_INDEX;

REPORT_MISSING_ARGUMENT:
        proc (rma_p_keyword_argument_idx);
        dcl     rma_p_keyword_argument_idx
				fixed bin parm;

        call ssu_$abort_line (sci_ptr, error_table_$noarg,
	  "^a must be followed by a^[n^] ^a.",
	  KEYWORD_ARGUMENT (rma_p_keyword_argument_idx),
	  (
	  index ("aeiouh",
	  substr (ARGUMENT_TYPE (rma_p_keyword_argument_idx), 1, 1)) > 0),
	  ARGUMENT_TYPE (rma_p_keyword_argument_idx));
        end REPORT_MISSING_ARGUMENT;

        end dm_send_request;




		    dm_set_free_area.pl1            04/24/85  1016.3re  04/24/85  0803.1       75159



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

This command sets the directory in which the dm_free_area is placed.  If there
is an existing dm_free_area known to the process (ie, get_dm_free_area_ has
been called already by the process), then it can be released.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 02/07/85.
Modified:
04/16/85 by Lindsey L. Spratt:  Added a pnotice.
*/
/* format: style2,ind3 */
%page;
dm_set_free_area:
   proc ();

/* START OF DECLARATIONS */
/* Automatic */

      dcl	    accept_control_argument
			       bit (1) aligned init ("0"b);
      dcl	    area_directory	       char (168) init (UNSET_DIRECTORY);
      dcl	    arg_idx	       fixed bin;
      dcl	    arg_len	       fixed bin (21);
      dcl	    arg_list_ptr	       ptr init (null);
      dcl	    arg_ptr	       ptr;
      dcl	    code		       fixed bin (35);
      dcl	    control_argument_idx   fixed bin;
      dcl	    force_interpretation_as_argument
			       bit (1) aligned init (NO);
      dcl	    is_active_function     bit (1) aligned init (NO);
      dcl	    number_of_args	       fixed bin;
      dcl	    release_old_area       bit (1) aligned init (NO);
      dcl	    return_arg_len	       fixed bin (21) init (0);
      dcl	    return_arg_ptr	       ptr init (null);
      dcl	    sci_ptr	       ptr init (null);
      dcl	    this_is_a_standalone_invocation
			       bit (1) aligned init (YES);

/* Based */

      dcl	    arg		       char (arg_len) based (arg_ptr);

/* Builtin */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    UNSET_DIRECTORY	       init (">NO DIR<") char (8) internal static options (constant);

      dcl	    (
	    YES		       init ("1"b),
	    NO		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);
      dcl	    myname	       init ("dm_set_free_area") char (16) internal static options (constant);

      dcl	    ARGUMENT_TYPE	       (6) internal static options (constant) char (64) varying
			       init ("pathname of the directory to contain dm free area",
			       "pathname of the directory to contain dm free area", "", "", "", "");
      dcl	    CONTROL_ARGUMENT       (6) internal static options (constant) char (64) varying
			       init ("-area_directory", "-adr", "-release_old_area", "-roa", "-no_release_old_area",
			       "-nroa");

/* Entry */

      dcl	    absolute_pathname_     entry (char (*), char (*), fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    get_dm_free_area_$set  entry (char (*), bit (1) aligned, ptr);
      dcl	    ssu_$abort_line	       entry () options (variable);
      dcl	    ssu_$arg_count	       entry (ptr, fixed bin);
      dcl	    ssu_$arg_ptr	       entry (ptr, fixed bin, ptr, fixed bin (21));
      dcl	    ssu_$destroy_invocation
			       entry (ptr);
      dcl	    ssu_$return_arg	       entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21));
      dcl	    ssu_$standalone_invocation
			       entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));

/* External */

      dcl	    (
	    error_table_$active_function,
	    error_table_$bad_arg,
	    error_table_$badopt,
	    error_table_$noarg
	    )		       fixed bin (35) external;

/* END OF DECLARATIONS */
      call cu_$arg_list_ptr (arg_list_ptr);
      call ssu_$standalone_invocation (sci_ptr, myname, "", arg_list_ptr, ABORT_ENTRY, code);

      on cleanup call CLEANUP ();

      call ssu_$arg_count (sci_ptr, number_of_args);

      accept_control_argument = YES;
      control_argument_idx = -1;

ARG_PROCESSING_LOOP:
      do arg_idx = 1 to number_of_args;
         call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
         if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES
         then call PROCESS_ARGUMENT (arg, control_argument_idx, accept_control_argument);
         else if accept_control_argument = YES
         then call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx, accept_control_argument,
	         force_interpretation_as_argument);
         else call REPORT_MISSING_ARGUMENT (control_argument_idx);
      end ARG_PROCESSING_LOOP;

      if control_argument_idx >= 0 & accept_control_argument = NO
      then call REPORT_MISSING_ARGUMENT (control_argument_idx);


      if area_directory = UNSET_DIRECTORY
      then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/An area directory pathname must be specified.");

      call get_dm_free_area_$set (area_directory, release_old_area, null ());


MAIN_RETURN:
      return;
%page;
ABORT_ENTRY:
   procedure ();
      call CLEANUP ();
      go to MAIN_RETURN;
   end ABORT_ENTRY;



CLEANUP:
   procedure ();
      call FINISH ();
   end CLEANUP;

FINISH:
   proc ();
      call ssu_$destroy_invocation (sci_ptr);
   end FINISH;

PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

      dcl	    pa_p_arg	       char (*) parm;
      dcl	    pa_p_control_argument_idx
			       fixed bin parm;
      dcl	    pa_p_accept_control_argument
			       bit (1) aligned parm;

      dcl	    pa_code	       fixed bin (35);

      pa_code = 0;

      goto ARGUMENT (pa_p_control_argument_idx);
ARGUMENT (-1):
      call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^/The argument ""^a"" is out of place.", arg);
      return;

ARGUMENT (1):					/* -area_directory */
ARGUMENT (2):					/* -adr */
      call absolute_pathname_ (arg, area_directory, code);
      if code ^= 0
      then call ssu_$abort_line (sci_ptr, code,
	      "^/Unable to convert the -area_directory option's argument ""^a"" to an absolute pathname.", arg);
      pa_p_accept_control_argument = YES;
      pa_p_control_argument_idx = -1;

   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument, pca_p_force_interpretation_as_argument);


      dcl	    pca_p_arg	       char (*) parm;
      dcl	    pca_p_control_argument_idx
			       fixed bin parm;
      dcl	    pca_p_accept_control_argument
			       bit (1) aligned parm;
      dcl	    pca_p_force_interpretation_as_argument
			       bit (1) aligned parm;

      pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
      pca_p_accept_control_argument = YES;
      pca_p_force_interpretation_as_argument = NO;

      go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
      call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* -area_directory */
CONTROL_ARGUMENT (2):				/* -adr */
      pca_p_accept_control_argument = NO;
      return;


CONTROL_ARGUMENT (3):				/* -release_old_area */
CONTROL_ARGUMENT (4):				/* -roa */
      release_old_area = YES;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


CONTROL_ARGUMENT (5):				/* -no_release_old_area */
CONTROL_ARGUMENT (6):				/* -nroa */
      release_old_area = NO;

      pca_p_control_argument_idx = -1;
      pca_p_accept_control_argument = YES;
      return;


   end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

      dcl	    cai_p_arg	       char (*);
      dcl	    cai_control_argument_idx
			       fixed bin;

      do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	 while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
      end;
      if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
      then return (-1);
      else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;

REPORT_MISSING_ARGUMENT:
   proc (rma_p_control_argument_idx);
      dcl	    rma_p_control_argument_idx
			       fixed bin parm;

      call ssu_$abort_line (sci_ptr, error_table_$noarg, "^a must be followed by a^[n^] ^a.",
	 CONTROL_ARGUMENT (rma_p_control_argument_idx),
	 (index ("aeiouh", substr (ARGUMENT_TYPE (rma_p_control_argument_idx), 1, 1)) > 0),
	 ARGUMENT_TYPE (rma_p_control_argument_idx));
   end REPORT_MISSING_ARGUMENT;

   end dm_set_free_area;




		    dm_set_journal_stamps.pl1       04/24/85  1016.3re  04/24/85  0803.1       29871



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

/* DESCRIPTION:

          dm_set_journal_stamps - a rather drastic way to force held pages to
     disk.  this sets the time stamp of all before image journals registered
     in ring zero to the time of invocation of this command, insuring that
     page control will write them out to disk at claim_mod_core time.

          THIS BYPASSES THE CONVENTIONS OF DATA MANAGEMENT PAGE PHASING.  IT
     IS TO BE USED IN THE EVENT OF AN EMERGENCY ONLY.  IN THE EVENT OF AN ESD
     FAILURE BEFORE JOURNAL TIME STAMPS ARE RESTORED, DATA BASES WILL BE LEFT
     IN UNKNOWN STATES.

*/

/*
HISTORY:
     
Written by Mike Pandolf, 08/01/83.
Modified:
09/14/83 by Lee A. Newcomb:  removed name sjs; concensus of author and 
	  myself is the command is too privileged to have a short name.
11/12/84 by Lindsey L. Spratt:  Changed name from set_journal_stamps to
            dm_set_journal_stamps.  Standardized format.  Removed all
            arguments, the command now only sets the journal stamps to be the
            current time.  Removed the ability to set the stamps directly,
            i.e.  without going through hc_dm_util$set_journal_stamp.  Changed
            to call dm_misc_util_$set_journal_stamps instead of
            dm_admin_gate_$set_journal_stamps.
04/11/85 by Lee A. Newcomb:  Fixed to call dm_admin_util_$set_journal_stamps,
            not dm_misc_=$=.
*/

/* format: style2,ind3 */
%page;
dm_set_journal_stamps:
   procedure () options (variable);


/* DECLARATIONS */

/* Automatic */

      dcl	    nargs		       fixed bin;
      dcl	    code		       fixed bin (35);

/* Based */
/* Constant */

      dcl	    MYNAME	       char (32) internal static options (constant) init ("dm_set_journal_stamps");

/* External */

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

/* Entry */

      dcl	    cu_$arg_count	       entry (fixed bin, fixed bin (35));
      dcl	    dm_admin_util_$set_journal_stamps
			       entry (fixed bin (71), fixed bin (35));
      dcl	    com_err_	       entry () options (variable);

/* Builtin */

      dcl	    clock		       builtin;

/* END OF DECLARATIONS */
%page;
      call cu_$arg_count (nargs, code);
      if code ^= 0
      then call ERROR_RETURN (code, "^/Unable to get the count of arguments given to this command.", "");

      if nargs ^= 0
      then call ERROR_RETURN (error_table_$too_many_args, "^/This command does not accept any arguments.", "");

      call dm_admin_util_$set_journal_stamps (clock (), code);
      if code ^= 0
      then call ERROR_RETURN (code, "^/Unable to set the journal stamps.", "");

MAIN_RETURN:
      return;



ERROR_RETURN:
   proc (er_p_code, er_p_msg, er_p_msg_arg);
      dcl	    er_p_code	       fixed bin (35) parameter;
      dcl	    er_p_msg	       char (*) parameter;
      dcl	    er_p_msg_arg	       char (*) parameter;

      call com_err_ (er_p_code, MYNAME, er_p_msg, er_p_msg_arg);
      goto MAIN_RETURN;
   end ERROR_RETURN;

   end dm_set_journal_stamps;




		    dm_set_system_dir.pl1           04/04/85  1114.9re  04/04/85  0824.6       95967



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

/*  DESCRIPTION:

	dm_set_system_dir is an unprivileged command to change the DM
     system directory for a process.  The subroutine it calls requires the
     user not be using a DMS and the directory must exist.  This directory
     will then be used for all further DM use, such as finding the current
     DM AIM directory for the process.

     Syntax:  dm_set_system_dir dir_path {-ctl_args}
*/

/* HISTORY:

Written by J. Bongiovanni, 08/15/82.
Modified:
09/16/82 by M. Pandolf:  for modified call to dm_priv_$initialize_system.
06/10/83 by Lee A. Newcomb:  to remove init_dm_system entry, better ways
	  exist.
10/07/83 by Lee A. Newcomb:  to use dm_daemon_gate_, not the obsolete
	  dm_priv_ gate.
10/10/84 by R. Michael Tague: Fixed auditing comments.  Added -auth argument
	  to set_dm_aim_dir.pl1.  Changed set_dm_aim_dir to call through tv
	  and to call $create_aim_control_seg.
11/22/84 by Lee A. Newcomb:  Removed the obsolete set_dm_aim_dir cmd.
	  AIM directories are now found via the use of
	  convert_authorization_$encode, with the system_low dir
	  being the same as the system dir.
02/21/85 by Lee A. Newcomb:  Added the control args -brief and -long
            (MCR7018), and changed to use the ERROR_RETURN, FINISH,
            PROCESS_ARGUMENT, etc.  mechanisms.
*/

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

/* START OF DECLARATIONS */

/*  Parameter  */
/*  Automatic  */
dcl  (
     accept_control_argument		bit (1) aligned init (YES),
     arg_idx			fixed bin init (0),
     arg_len			fixed bin (21) init (0),
     arg_list_ptr			ptr init (null),
     arg_ptr			ptr init (null),
     code				fixed bin (35) init (0),
     control_argument_idx		fixed bin init (1), /* 1 ==> accept pathname */
     dir_name			char (168) init (BAD_DIR_PATHNAME),
     force_interpretation_as_argument	bit (1) aligned init (NO),
     is_active_function		bit (1) aligned init (NO),
     number_of_args			fixed bin init (-1),
     print_confirmation_of_setting	bit (1) aligned init (YES),
     sci_ptr			ptr init (null)
     )				automatic;

/* Based  */
dcl  arg				char (arg_len) based (arg_ptr);

/* Builtin */
dcl  (addr, hbound, index, null, substr)
				builtin;

/* Condition */
dcl  cleanup			condition;

/* Constant */
dcl  (
     ARGUMENT_TYPE			(6) char (64) varying
				init ("system dir pathname",
				"system dir pathname", "", "", "", ""),
     BAD_DIR_PATHNAME		char (2) init ("><"),
     CONTROL_ARGUMENT		(6) char (64) varying
				init ("", "", "-brief", "-bf", "-long",
				"-lg"),
     IOA_GENERAL_RS_NO_NEW_LINE	bit (1) aligned init (""b),
     IOA_GENERAL_RS_DONT_PAD		bit (1) aligned init (""b),
     NO				bit (1) aligned init (""b),
     SSU_INVOCATION_ERR_MSG		char (49)
				init (
				"Cannot establish standalone subsystem invocation."
				),
     YES				bit (1) aligned init ("1"b),
     myname			char (32) init ("dm_set_system_dir")
     )				internal static options (constant);

/*  Entry  */
dcl  (
     absolute_pathname_		entry (char (*), char (*),
				fixed bin (35)),
     com_err_			entry options (variable),
     cu_$arg_list_ptr		entry (ptr),
     dm_misc_util_$set_system_dir	entry (char (*)),
     ioa_				entry options (variable),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned),
     ssu_$abort_line		entry () options (variable),
     ssu_$arg_ptr			entry (ptr, fixed bin, ptr,
				fixed bin (21)),
     ssu_$destroy_invocation		entry (ptr),
     ssu_$return_arg		entry (ptr, fixed bin, bit (1) aligned,
				ptr, fixed bin (21)),
     ssu_$standalone_invocation	entry (ptr, char (*), char (*), ptr,
				entry, fixed bin (35))
     )				external;

/*  External */
dcl  (
     error_table_$active_function,
     error_table_$bad_arg,
     error_table_$badopt,
     error_table_$noarg
     )				fixed bin (35) external;

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

SETUP_INVOCATION:
   do;
      call cu_$arg_list_ptr (arg_list_ptr);
      on cleanup call CLEAN_UP ();

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

      call ssu_$return_arg (sci_ptr, number_of_args, is_active_function,
	 (null ()), (0));				/* don't care what AF return info is */

      if is_active_function then
         call ERROR_RETURN (error_table_$active_function);
   end SETUP_INVOCATION;


ARG_PROCESSING_LOOP:
   do arg_idx = 1 to number_of_args;
      call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
      if index (arg, "-") ^= 1 | force_interpretation_as_argument = YES then
         call PROCESS_ARGUMENT (arg, control_argument_idx,
	    accept_control_argument);
      else if accept_control_argument = YES then
         call PROCESS_CONTROL_ARGUMENT (arg, control_argument_idx,
	    accept_control_argument, force_interpretation_as_argument);
      else call REPORT_MISSING_ARGUMENT (control_argument_idx);
   end ARG_PROCESSING_LOOP;

   if control_argument_idx >= 0 & accept_control_argument = NO then
      call REPORT_MISSING_ARGUMENT (control_argument_idx);

/* set it */
   if dir_name = BAD_DIR_PATHNAME then
      call ERROR_RETURN (error_table_$noarg, "No directory path given.");
   call dm_misc_util_$set_system_dir (dir_name);

   if print_confirmation_of_setting then		/* tell user we did it */
      call ioa_ ("^a: Data Management Per-System directory set to ^a", myname,
	 dir_name);

   call RETURN ();					/* and go home */
%page;
MAIN_RETURN:
   return;
%skip (4);
RETURN:
   proc ();
ABORT_ENTRY:
   entry ();					/* ABORT currently same as RETURN */

   call FINISH ();
   go to MAIN_RETURN;

   end RETURN;
%skip (4);
FINISH:
   proc ();
CLEAN_UP:
   entry ();					/* CLEAN_UP currently same as FINISH */

   call ssu_$destroy_invocation (sci_ptr);

   return;

   end FINISH;
%page;
PROCESS_ARGUMENT:
   proc (pa_p_arg, pa_p_control_argument_idx, pa_p_accept_control_argument);

dcl  pa_p_arg			char (*) parm;
dcl  pa_p_control_argument_idx	fixed bin parm;
dcl  pa_p_accept_control_argument	bit (1) aligned parm;

dcl  pa_code			fixed bin (35) init (0);


   goto ARGUMENT (pa_p_control_argument_idx);

ARGUMENT (-1):
   call ERROR_RETURN (error_table_$bad_arg,
        "^/The argument ""^a"" is out of place.", arg);
   return;

ARGUMENT (1):					/* system dir pathname */
ARGUMENT (2):					/* system dir pathname */
   if dir_name ^= BAD_DIR_PATHNAME then
      call ERROR_RETURN (error_table_$bad_arg,
	 "Attempt to use more than one system directory: ^a", arg);
   call absolute_pathname_ (arg, dir_name, code);
   if code ^= 0 then
      call ERROR_RETURN (code, arg);
   control_argument_idx = 1;
   accept_control_argument = YES;
   return;

   end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
   proc (pca_p_arg, pca_p_control_argument_idx, pca_p_accept_control_argument,
        pca_p_force_interpretation_as_argument);


dcl  pca_p_arg			char (*) parm;
dcl  pca_p_control_argument_idx	fixed bin parm;
dcl  pca_p_accept_control_argument	bit (1) aligned parm;
dcl  pca_p_force_interpretation_as_argument
				bit (1) aligned parm;

   pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);
   pca_p_accept_control_argument = YES;
   pca_p_force_interpretation_as_argument = NO;

   go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):				/* not a control argument */
   call ERROR_RETURN (error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):				/* system dir pathname */
CONTROL_ARGUMENT (2):				/* system dir pathname */
   pca_p_accept_control_argument = NO;
   return;


CONTROL_ARGUMENT (3):				/* -brief */
CONTROL_ARGUMENT (4):				/* -bf */
   print_confirmation_of_setting = NO;

   pca_p_control_argument_idx = 1;
   pca_p_accept_control_argument = YES;
   return;


CONTROL_ARGUMENT (5):				/* -long */
CONTROL_ARGUMENT (6):				/* -lg */
   print_confirmation_of_setting = YES;

   pca_p_control_argument_idx = 1;
   pca_p_accept_control_argument = YES;
   return;

   end PROCESS_CONTROL_ARGUMENT;
%page;
CONTROL_ARGUMENT_INDEX:
   proc (cai_p_arg) returns (fixed bin);

dcl  cai_p_arg			char (*);
dcl  cai_control_argument_idx		fixed bin;

   do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
        while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg);
   end;
   if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1) then
      return (-1);
   else return (cai_control_argument_idx);

   end CONTROL_ARGUMENT_INDEX;
%skip (4);
REPORT_MISSING_ARGUMENT:
   proc (rma_p_control_argument_idx);

dcl  rma_p_control_argument_idx	fixed bin parm;

   call ERROR_RETURN (error_table_$noarg, "^a must be followed by a^[n^] ^a.",
        CONTROL_ARGUMENT (rma_p_control_argument_idx),
        (
        index ("aeiouh",
        substr (ARGUMENT_TYPE (rma_p_control_argument_idx), 1, 1)) > 0),
        ARGUMENT_TYPE (rma_p_control_argument_idx));

   end REPORT_MISSING_ARGUMENT;
%page;
ERROR_RETURN_FROM_SSU_SETUP:
   proc (erfss_p_code);

dcl  erfss_p_code			fixed bin (35) parameter;

   call com_err_ (erfss_p_code, myname, SSU_INVOCATION_ERR_MSG);

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

   end ERROR_RETURN_FROM_SSU_SETUP;
%skip (4);
ERROR_RETURN:
   proc options (variable);

dcl  (
     er_arg_list_ptr		ptr,
     er_code			fixed bin (35),
     er_message			char (1024),
     er_message_length		fixed bin (21)
     )				automatic;

dcl  (
     er_fixed_bin_35_value		fixed bin (35),
     er_message_overlay		char (er_message_length)
     )				based;

   call cu_$arg_list_ptr (er_arg_list_ptr);
   er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_fixed_bin_35_value;

   if er_arg_list_ptr -> arg_list.arg_count > 1 then do;
      call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message,
	 er_message_length, IOA_GENERAL_RS_DONT_PAD,
	 IOA_GENERAL_RS_NO_NEW_LINE);
      call ssu_$abort_line (sci_ptr, er_code,
	 addr (er_message) -> er_message_overlay);
   end;
   else						/* no extra info */
        call ssu_$abort_line (sci_ptr, er_code);

   end ERROR_RETURN;
%page;
%include arg_list;


   end dm_set_system_dir;




		    dm_shutdown_handler.pl1         01/04/85  0952.6re  01/03/85  1150.6       35163



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

/* format: ^indcomtxt */
/* DESCRIPTION:

         This    program    is   the   default   static   handler   for   the
     dm_shutdown_scheduled_ IPS.  It resets any  previously  set  DM  shutdown
     timers.     It  then  sets  up  new  alarm  call  timers  to  signal  the
     dm_shutdown_warning_  and  dm_user_shutdown_  conditions  in   the   user
     process.

          Currently, nothing is done to warn users of DM shutdown cancellation
     it  the warning signal has already been sent.  This will require a static
     datum to store the time of the warning for comparison  and  a  signalling
     mechanism to inform users of the cancellation.
*/

/* HISTORY:

Written by Lee A. Newcomb, 09/20/84.
Modified:
10/29/84 by Lee A. Newcomb:  Fixed targets of alarm timers to be
            dm_misc_util_$signal_...
12/10/84 by Lindsey Spratt:  Changed to catch timer_manager_err when calling
	  timer_manager_$reset_alarm_call.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */

dm_shutdown_handler:
   proc ();

/* START OF DECLARATIONS */
/* Parameter */

/* Automatic */
dcl  (
     saved_ips_mask			bit (36) aligned init (""b),
     user_shutdown_time		fixed bin (71) init (0)
     )				automatic;

/* Based */
/* Builtin */

dcl  null				builtin;

/* Condition */
dcl  (cleanup, timer_manager_err)	condition;

/* Constant */

/* Entry */

dcl  (
     dm_misc_util_$get_shutdown_warning_time
				entry returns (fixed bin (71)),
     dm_misc_util_$get_user_shutdown_time
				entry returns (fixed bin (71)),
     dm_misc_util_$is_process_using_dm	entry returns (bit (1) aligned),
     dm_misc_util_$signal_user_shutdown entry (),
     dm_misc_util_$signal_shutdown_warning
				entry (),
     hcs_$reset_ips_mask		entry (bit (36) aligned,
				bit (36) aligned),
     hcs_$set_ips_mask		entry (bit (36) aligned,
				bit (36) aligned),
     timer_manager_$alarm_call	entry (fixed bin (71), bit (2), entry),
     timer_manager_$reset_alarm_call	entry (entry)
     );

/* External */

/* END OF DECLARATIONS */
%page;
   on cleanup call FINISH ();
   call hcs_$set_ips_mask (""b, saved_ips_mask);

   if dm_misc_util_$is_process_using_dm () then
HANDLE_DM_SHUTDOWN_SCHEDULED_IPS:
      do;

RESET_OLD_SHUTDOWN_TIMERS:				/* if any */
      begin;
dcl  next_reset_label		label variable;
         on timer_manager_err goto next_reset_label;
         next_reset_label = SIGNAL_USER_SHUTDOWN_RESET;
         call timer_manager_$reset_alarm_call (
	    dm_misc_util_$signal_shutdown_warning);
SIGNAL_USER_SHUTDOWN_RESET:
         next_reset_label = DONE_RESETTING;
         call timer_manager_$reset_alarm_call (
	    dm_misc_util_$signal_user_shutdown);
DONE_RESETTING:
         revert timer_manager_err;
      end RESET_OLD_SHUTDOWN_TIMERS;

      user_shutdown_time = dm_misc_util_$get_user_shutdown_time ();
      if user_shutdown_time ^= 0 then
SET_SHUTDOWN_TIMERS:
         do;

         call timer_manager_$alarm_call (
	    dm_misc_util_$get_shutdown_warning_time (),
	    "00"b /* abs. usec. */, dm_misc_util_$signal_shutdown_warning);
         call timer_manager_$alarm_call (user_shutdown_time,
	    "00"b /* abs. usec. */, dm_misc_util_$signal_user_shutdown);

      end SET_SHUTDOWN_TIMERS;

   end HANDLE_DM_SHUTDOWN_SCHEDULED_IPS;

   call FINISH ();

MAIN_RETURN:
   return;


/* end dm_shutdown_handler; */
%page;
FINISH:
   proc ();

   if saved_ips_mask ^= ""b then
      call hcs_$reset_ips_mask (saved_ips_mask, saved_ips_mask);

   return;

   end FINISH;


   end dm_shutdown_handler;




		    dm_signal_shutdown_warning.pl1  04/04/85  1114.9re  04/04/85  0824.6       67581



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

/* format: ^indcomtxt */
/* DESCRIPTION:

         This     procedure,     dm_signal_shutdown_warning,    signals    the
     dm_shutdown_warning_  condition  in  a user process.  It is the target of
     the  first  alarm  call  set  up  by  a  process  that  has  received the
     dm_shutdown_scheduled_  IPS, or per-process initialization if the warning
     time  for  the  DMS  has  already  passed.   It  builds  a condition info
     structure  giving  the  reason for the DMS shutdown and the planned time;
     calls signal_ to allow the user to process the condition if desired (with
     the  quiet  restart  set);  and if it gets control back, prints a warning
     message on the error_output I/O switch warning the user when the DMS will
     shutdown.   In  general,  we  do  not expect users to catch the signalled
     condition, but do it as a convenience.

	The   condition   info  structure  is  found  in  the  include  file
     dm_shut_warn_info.incl.pl1  and is named dm_shutdown_warning_info.  There
     is  a  flag  the  user may set to suppress the warning message from being
     printed.

	If the user process is an absentee, no message is printed.
*/

/* HISTORY:

Written by Lee A. Newcomb, 11/10/83.
Modified:
04/19/84 by Lee A. Newcomb:  to upgrade from prototype version.
07/16/84 by R. Michael Tague:  Changed the call dm_util_$using_dm to
            call dm_misc_util_$dm_is_process_using_dm.
08/17/84 by Lee A. Newcomb:  changed dm_per_system_$ calls to go through
	  the dm_misc_util_ TV.
09/19/84 by Lee A. Newcomb:  Renamed from dm_shut_warn_handler_ and made
            changes to signal the dm_shutdown_warning_ condition and output
            the warning message without assuming that txns have been turned
            off.
10/29/84 by Lee A. Newcomb:  Fixed to not use dm_ prefix on
            dm_misc_util_$is_process_using_dm.
03/11/85 by Lindsey L. Spratt:  y Reformatted the message.  Changed to use
            user_io instead of error_output, ioa_$ioa_switch instead of
            ioa_$ioa_stream.
*/

/* format: style2,^inddcls,linecom,ifthendo,ifthen,^indnoniterdo,dclind5,idind35 */

dm_signal_shutdown_warning:
     proc ();

/* START OF DECLARATIONS */

/* Automatic */
dcl  (
     (begin_shutdown_time_string, user_shutdown_time_string)
				char (6),
     curr_process_type		fixed bin (17),	/* for NOT warning absentees */
     1 local_dm_shutdown_warning_info	aligned like dm_shutdown_warning_info,
     time_string			char (24)		/* for getting printable times */
     )				automatic;

/* Based */
/* Builtin */
dcl  (addr, length, null, size, substr, unspec)
				builtin;

/* Condition */
dcl  ioa_error			condition;

/* Constant */
/* Entry */
dcl  (
     date_time_			entry (fixed bin (71), char (*)),
     dm_misc_util_$get_shutdown_reason	entry returns (char (64)),
     dm_misc_util_$get_begin_shutdown_time
				entry returns (fixed bin (71)),
     dm_misc_util_$get_user_shutdown_time
				entry returns (fixed bin (71)),
     dm_misc_util_$is_process_using_dm	entry () returns (bit (1) aligned),
     ioa_$ioa_switch		entry () options (variable),
     signal_			entry () options (variable),
     user_info_$process_type		entry (fixed bin)
     );

/* External */

dcl  iox_$user_io			ptr ext static;

/* END OF DECLARATIONS */
%page;
/* Is the process still using DM?  If not, warning means nothing. */

	if dm_misc_util_$is_process_using_dm () then
WARN_USER:
	     do;

/* OK, we must fill in the info structure. */
/*   First, the condition info header portion.  However, header.info_string */
/*   we leave for after we fill in the DM specific info. */

	     unspec (local_dm_shutdown_warning_info) = "0"b;
						/* null flags and all */
	     local_dm_shutdown_warning_info.header.length = size (local_dm_shutdown_warning_info);
						/* nothing like self-definition */
	     local_dm_shutdown_warning_info.header.version = DM_SHUTDOWN_WARNING_INFO_VERSION_1;
	     local_dm_shutdown_warning_info.header.quiet_restart = "1"b;
						/* turn quiet_restart on */


/* now the DM part of the condition info. */
	     local_dm_shutdown_warning_info.begin_shutdown_time = dm_misc_util_$get_begin_shutdown_time ();
	     local_dm_shutdown_warning_info.user_shutdown_time = dm_misc_util_$get_user_shutdown_time ();
	     local_dm_shutdown_warning_info.reason = dm_misc_util_$get_shutdown_reason ();

/* Now must build the info_string.  This is to save us work later and */
/* the user work if he decides not to return to us.  This requires us */
/* to extract the time of the begin and user shutdown steps from the  */
/* date_time string after calling date_time_.  This should be changed */
/* to use date_time_$format to get the user's per-process time format */
/* when it will not interfere with controlled releases.  Care must be	*/
/* used to make sure the 256 character limit of info_string is not	*/
/* overflowed.						*/

	     call date_time_ (local_dm_shutdown_warning_info.begin_shutdown_time, time_string);
	     begin_shutdown_time_string = substr (time_string, 11, 6);
	     call date_time_ (local_dm_shutdown_warning_info.user_shutdown_time, time_string);
	     user_shutdown_time_string = substr (time_string, 11, 6);

	     local_dm_shutdown_warning_info.header.info_string =
		"     DM is shutting down; no new transactions will be allowed after "
		|| begin_shutdown_time_string || ".
     Please use the dm_user_shutdown command, or, at " || user_shutdown_time_string || ",
     a forced shutdown will be done.  Shutdown reason:
     ";
	     local_dm_shutdown_warning_info.header.info_string =
		local_dm_shutdown_warning_info.header.info_string
		||
		substr (local_dm_shutdown_warning_info.reason, 1,
		min (length (rtrim (local_dm_shutdown_warning_info.reason)),
		256 - length (local_dm_shutdown_warning_info.header.info_string)));
%page;
/* NOW signal the shutdown warning to the user with the above info. */

	     call signal_ ("dm_shutdown_warning_", null (), addr (local_dm_shutdown_warning_info), null ());

/* To get to this point, the user must have either (1) not handled the     */
/* condition we signalled, or (2) handled it, but used continue_to_signal_ */
/* to return control here.  In either case, we expect that the user wishes */
/* to see the shutdown warning, unless the dont_print_warning flag in the  */
/* condition info structure has been flipped on.  However, if the process  */
/* is absentee, we do not add to the absout, but just return to preserve   */
/* any user formatting.  The warning message is output on the error_output */
/* IO switch. */

	     call user_info_$process_type (curr_process_type);
	     if curr_process_type ^= 2 &		/* not absentee */
		^local_dm_shutdown_warning_info.flags.dont_print_warning then
OUTPUT_WARNING:
		do;
		on ioa_error go to WARNING_FAILED;
		call ioa_$ioa_switch (iox_$user_io, local_dm_shutdown_warning_info.header.info_string);
WARNING_FAILED:					/* in case error_output is not open or something */
	     end OUTPUT_WARNING;


	end WARN_USER;


MAIN_RETURN:
	return;


/* end dm_signal_shutdown_warning; */
%page;
%include condition_info_header;
%page;
%include dm_shut_warn_info;


     end dm_signal_shutdown_warning;




		    dm_signal_user_shutdown.pl1     04/24/85  1016.3re  04/24/85  0803.1       86040



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

/* DESCRIPTION:

	This  program,  dm_signal_user_shutdown,  is  the target of an alarm
     call  channel  set  up by the handler for the dm_shutdown_scheduled_ IPS.
     It  builds  the  dm_user_shutdown_info  condition  info  structure, calls
     signal_  so  the user process may handle the condition, outputs a warning
     user  shutdown  is  in  progress on the error_output I/O switch, and then
     calls  transaction_manager_$user_shutdown  to actually do the per-process
     shutdown.   If  a  transaction  was  acted  upon  in any way, the user is
     informed  (again  on the error_output switch).  Care must be taken by the
     software  to  not  invoke  per-process  initialization  in the process of
     shutdown.   It is possible for a user process to have shutdown before the
     alarm goes off, in which case we just return.
*/

/* HISTORY:

Written by Lee A. Newcomb, 11/15/83.
Modified:
04/19/84 by Lee A. Newcomb:  upgraded from prototype version.
05/10/84 by Lee A. Newcomb:  to use dm_tm_shutdown_info.incl.pl1 properly.
07/16/84 by R. Michael Tague:  Changed the call dm_util_$using_dm to
            call dm_misc_util_$dm_is_process_using_dm.
08/17/84 by Lee A. Newcomb:  Replaced dm_per_system_$... calls with calls to
	  the dm_misc_util_$ TV.
09/19/84 by Lee A. Newcomb:  Renamed from dm_user_shut_handler_ and made to
            understand user settable flags upon return from the signal_ call.
10/29/84 by Lee A. Newcomb:  Fixed to not use dm_ prefix on
            dm_misc_util_$is_process_using_dm.
02/21/85 by Lee A. Newcomb:  Fixed to reset the IPS mask before signalling.
03/11/85 by Lindsey L. Spratt:  Reformatted the shutdown message.  Changed to
            use ioa_$ioa_switch instead of $ioa_stream, changed to put the
            message out on user_io instead of error_output.
04/08/85 by Lee A. Newcomb:  Fixed to use the maxlength builtin instead of the
            constant 256 when filling in the condition_info.info_string
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;
dm_signal_user_shutdown:
   proc ();

/* START OF DECLARATIONS */

/* Automatic */
dcl  (
     code				fixed bin (35) init (0),
     1 local_dm_user_shutdown_info	aligned like dm_user_shutdown_info,
     saved_ips_mask			bit (36) aligned init ("0"b),
     tm_shutdown_info_idx		fixed bin
     )				automatic;

/* Builtin */
dcl  (addr, bin, length, maxlength, min, null, rtrim, size, unspec)
				builtin;

/* Condition */
dcl  (cleanup, ioa_error)		condition;

/* Constant */
dcl  (
     ALLOW_NO_INTERRUPTIONS_MASK	bit (36) aligned init (""b),
     myname			char (32) varying
				init ("dm_signal_user_shutdown")
     )				internal static options (constant);

/* Entry */
dcl  (
     dm_misc_util_$is_process_using_dm	entry () returns (bit (1) aligned),
     dm_misc_util_$get_shutdown_reason	entry returns (char (64)),
     get_system_free_area_		entry () returns (ptr),
     hcs_$reset_ips_mask		entry (bit (36) aligned,
				bit (36) aligned),
     hcs_$set_ips_mask		entry (bit (36) aligned,
				bit (36) aligned),
     ioa_$ioa_switch		entry () options (variable),
     signal_			entry () options (variable),
     sub_err_			entry () options (variable),
     transaction_manager_$user_shutdown entry (ptr, ptr, fixed bin (35))
     );

/* External */

dcl  iox_$user_io			ptr ext static;
dcl  (
     error_table_$unimplemented_version fixed bin (35)
     )				ext;

/* END OF DECLARATIONS */
%page;
/* Mask IPS' while getting shutdown info so user can't do	*/
/* user shutdown by breaking and calling dm_user_shutdown;	*/
/* causing us to take an error if a start is done.  We will	*/
/* reset the mask before signalling, however.		*/

   on cleanup call CLEAN_UP ();
   call hcs_$set_ips_mask (ALLOW_NO_INTERRUPTIONS_MASK, saved_ips_mask);

/* Is the process still using DM?  If not, our job is done. */

   if dm_misc_util_$is_process_using_dm () then
SIGNAL_USER_SHUTDOWN:
      do;

/* We fill in the dm_user_shutdown_info condition info structure. */

      unspec (local_dm_user_shutdown_info) = ""b;		/* clear flags and all */
      local_dm_user_shutdown_info.header.length =
	 size (local_dm_user_shutdown_info);		/* nothing like self-definition */
      local_dm_user_shutdown_info.header.version =
	 DM_USER_SHUTDOWN_INFO_VERSION_1;
      local_dm_user_shutdown_info.header.quiet_restart = "1"b;
						/* turn quiet_restart on */

/* now the DM part of the condition info. */
      local_dm_user_shutdown_info.reason =
	 dm_misc_util_$get_shutdown_reason ();

      call hcs_$reset_ips_mask (saved_ips_mask, saved_ips_mask);
						/* user may interrupt now */

/* fill in the info_string for our convenience, or a user's that	*/
/* handles the condition without returning to here.		*/

      local_dm_user_shutdown_info.header.info_string =
	 "     The Data Management system is shutting down; starting DM user shutdown.
     Shutdown reason:
     "
	 ;
      local_dm_user_shutdown_info.header.info_string =
	 local_dm_user_shutdown_info.header.info_string
	 ||
	 substr (local_dm_user_shutdown_info.reason, 1,
	 min (length (rtrim (local_dm_user_shutdown_info.reason)),
	 maxlength (local_dm_user_shutdown_info.header.info_string)
	 - length (local_dm_user_shutdown_info.header.info_string)));
%page;
/* NOW signal the shutdown warning to the user with the above info. */

      call signal_ ("dm_user_shutdown_", null (),
	 addr (local_dm_user_shutdown_info), null ());

/* To get to this point, the user must have either (1) not handled	*/
/* the condition we signalled, or (2) handled it, but used		*/
/* continue_to_signal_ to return control here.  In either case, check	*/
/* if the user wishes to call transaction_manager_$user_shutdown	*/
/* and/or recieve any warning messages.  If the user process is not	*/
/* shutdown as far as DM is concerned, the process will get bumped by	*/
/* the Daemon later in DMS shutdown.				*/
/* We do not mask IPS' again, but try to not call shutdown if the	*/
/* has already done DM shutdown.  The window is very small, and the	*/
/* worst that can happen is tm_$user_shutdown gets called and does	*/
/* nothing, and the user sees some messages on the error_output I/O	*/
/* switch which don't mean much.				*/

      if ^local_dm_user_shutdown_info.flags.dont_do_user_shutdown
	 & dm_misc_util_$is_process_using_dm () then
DO_USER_SHUTDOWN:
         do;

         if ^local_dm_user_shutdown_info.flags.dont_print_warning then do;
	  on ioa_error go to IGNORE_USER_SHUTDOWN_WARNING;
	  call ioa_$ioa_switch (iox_$user_io,
	       local_dm_user_shutdown_info.info_string);
IGNORE_USER_SHUTDOWN_WARNING:
         end;

         call transaction_manager_$user_shutdown (get_system_free_area_ (),
	    tm_shutdown_info_ptr, code);

         if ^local_dm_user_shutdown_info.dont_print_warning then
OUTPUT_USER_SHUTDOWN_RESULTS:
	  do;

	  if tm_shutdown_info_ptr ^= null () then
OUTPUT_TM_USER_SHUTDOWN_INFO:
	     do;

	     call CHECK_VERSION (tm_shutdown_info.version,
		TM_SHUTDOWN_INFO_VERSION_1, "tm_shutdown_info");

	     on ioa_error go to IGNORE_TM_SHUTDOWN_RESULTS_OUTPUT;

	     call ioa_$ioa_switch (iox_$user_io,
		"^a:^2xAdjusted ^[no^s^;^d^] transaction^[s^].", myname,
		(tm_shutdown_info.count = 0), tm_shutdown_info.count,
		(tm_shutdown_info.count ^= 1));
%page;
PER_TXN_INFO:
	     do tm_shutdown_info_idx = 1 to tm_shutdown_info.count;
	        call ioa_$ioa_switch (iox_$user_io,
		   "^5xTransaction ^d ^a^(, error code = ^d^).",
		   bin (tm_shutdown_info.txn_id (tm_shutdown_info_idx)),
		   OP_NAME (tm_shutdown_info
		   .op_completed (tm_shutdown_info_idx)),
		   (tm_shutdown_info.error_code (tm_shutdown_info_idx)
		   ^= 0),
		   tm_shutdown_info.error_code (tm_shutdown_info_idx));
	     end PER_TXN_INFO;

	  end OUTPUT_TM_USER_SHUTDOWN_INFO;

	  if code ^= 0 then				/* check code returned */
	     call sub_err_ (code, myname, ACTION_DEFAULT_RESTART,
		"Error occurred during DM user shutdown.");

         end OUTPUT_USER_SHUTDOWN_RESULTS;

IGNORE_TM_SHUTDOWN_RESULTS_OUTPUT:
      end DO_USER_SHUTDOWN;

   end SIGNAL_USER_SHUTDOWN;

   call FINISH ();

MAIN_RETURN:
   return;


/* end dm_signal_user_shutdown; */
%page;
/* FINISH and CLEAN_UP currently do the same work.	*/

FINISH:
   proc ();
CLEAN_UP:
   entry ();

   if tm_shutdown_info_ptr ^= null () then
      free tm_shutdown_info;
   if saved_ips_mask ^= ""b then
      call hcs_$reset_ips_mask (saved_ips_mask, saved_ips_mask);


   end FINISH;
%skip (4);
CHECK_VERSION:
   proc (chkvs_input_version, chkvs_expected_version, chkvs_structure_name);

dcl  (
     chkvs_input_version		char (8) aligned,
     chkvs_expected_version		char (8) aligned,
     chkvs_structure_name		char (*)
     )				parameter;

   if chkvs_input_version ^= chkvs_expected_version then
      call sub_err_ (error_table_$unimplemented_version, myname,
	 ACTION_CANT_RESTART, "Expected version ^a of ^a, received ^a.",
	 chkvs_expected_version, chkvs_structure_name, chkvs_input_version);

   return;


   end CHECK_VERSION;
%page;
%include condition_info_header;
%page;
%include dm_user_shut_info;
%page;
%include dm_tm_shutdown_info;
%page;
%include sub_err_flags;


   end dm_signal_user_shutdown;




		    dm_system_shutdown.pl1          04/04/85  1114.9re  04/04/85  0824.6      258525



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

/* format: ^indcomtxt */
/* DESCRIPTION:

       This routine implements the dm_system_shutdown command and the 
  "shutdown" DM daemon request.  The command and request are almost
  identical, having the same syntax, but differ slightly in how they are
  invoked.  The shutdown request is an ssu_ subsystem request.
  
  The main procedure implements the dm_system_shutdown command. It sets up
  up an ssu_ standalone invocation.  
  The entry dm_system_shutdown$shutdown_request implements the request.
  It is invoked from within an ssu_ subsystem, so does not have to create
  a subsystem invocation, instead just using the p_sci_ptr passed to
  it as a parameter to identify the subsystem invocation.  As required of
  an ssu_ request procedure it also takes a p_info_ptr parameter, but that
  parameter is not used.
  
  The command is expected to be executed in a Data Management administrator's
  process, the request in the Data Management daemon's process.  Despite the
  difference, for simplicity the code is the same no matter which process in
  which it is being executed.  This is why a request is sent to the daemon
  to finish up scheduling the shutdown, even though we might already be in
  the daemon's process.
  
  Error handling is done in the standard ssu_ manner, using ssu_$abort_line
  and ssu_$print_message.  
  
  The argument processing technology deserves some explanation.  The constant
  array CONTROL_ARGUMENT has the names of all control arguments.  The constant
  array ARGUMENT_TYPE contains a short description of the type of argument 
  expected to follow a given control argument.  The index into CONTOL_ARGUMENT
  of a control argument corresponds with the index of its expected argument 
  type in ARGUMENT_TYPE.  The type is used in error messages only.
  
  Two variables control the argument processing, accept_control_argument (a
  flag) and control argument_idx (an array index).  If accept_control_argument
  is on, the argument being processed is expected to be a control argument.  
  If it is off, the argument must not be a control argument.  When 
  accept_control_argument is on, control_argument_idx is equal to -1,
  otherwise it is equal to the CONTROL_ARGUMENT index of the last control 
  argument last processed.
  
  Each argument is processed in one iteration of the ARG_PROCESSING_LOOP as
  follows: If accept_control_argument is on, process it as a control argument
  by calling PROCESS_CONTROL_ARGUMENT, which will set accept_control_argument
  to off if it expects an argument to follow and will set control_argument_idx
  to its CONTROL_ARGUMENT index.  If accept_control_argument is off and the
  argument being processed does not begin with "-" (the trigger character
  for control arguments), process the argument by calling
  PROCESS_ARGUMENT, which will reset accept_control_argument to on and 
  control_argument_idx to -1 if no more arguments are expected for the
  current control argument.  If accept_control_argument is off and the
  argument being processed is a supported control argument, abort;
  otherwise call PROCESS_ARGUMENT.
  
  PROCESS_ARGUMENT also processes the argument it is given is a fashion
  particular to the current control argument (e.g., processes the 
  argument following -user_bump_time as a time string, the one following
  -dm_system_directory as a pathname) and stores the processed value of the
  argument in the arg_info structure.
  
  
  Following is info file documentation of the dm_system_shutdown command.
  The request has the same syntax, with the name shutdown instead of
  dm_system_shutdown.
  
                                (continued)
  
  08/21/84 dm_system_shutdown
  
  Syntax:  dm_system_shutdown {-cargs}


  Function:  This command schedules a Data Management system (DMS)
  shutdown.  The DMS can be specified by the pathname of the its
  per-system directory, i.e., the directory in which it resides.  By
  default, the DMS which this process is currently using is scheduled to
  be shut down.  Processes using the DMS are notified of the scheduled
  shutdown via the dm_shutdown_scheduled_ IPS signal.
  
  The system shutdown process consists of five events executed at the
  following five points in time, usually, but not necessarily, in the
  given order:
  
  1) At user-warning-time:
     a warning message is printed in each process using the
     DMS as follows:
  
     DM is shutting down; no new transaction will be allowed after
     9:00.  Please use the dm_ser_shutdown command, or, at 9:15, a
     forced shutdown will be done.  Shutdown reason:  {reason from
     dm_system_data_}.

  2) At begin-shutdown-time:
     the Data Management daemon puts the DMS in a state wherin
     no new transactions can be created.  This is considered the
     beginning of the DMS shutdown.

  3) At user-shutdown-time:
     for each user process still using the DMS, a DM user
     shutdown is executed in the process.  A message is printed
     informing the user, as follows:

     The Data Management system is shutting down; starting DM user
     shutdown.  Shutdown reaon:  {reason from dm_system_data_}.

  4) At user-bump-time:
     the Data Management daemon bumps each process still using
     the DMS.

  5) At daemon-logout-time:
     the shutdown is made complete by logging out the Data
     Management daemon.

  The time of each event is determined according to the following rules:

   1) If the time is specified with a control argument ending in
      "_time" the event is scheduled to occur at that time.
   2) Starting from each specified time, the times for
      subsequent events are calculated using the specified or
      default delays, until an event is reached which has a
      specified time.
   3) If the first event is not scheduled, then starting from
      the first specified time, calculate the times for previous
      events using specified or default delays, until the first
      event is reached.
   4) If no times are specified, the user-bump-time defaults to
      the scheduled Multics shutdown time, and other times are
      calculated from there.
   5) If no times are specified and there is no Multics shutdown
      scheduled, an error message is returned.


  Control arguments:
  -dm_system_directory PATH, -dmsd PATH
     is the pathname, PATH, of the DM per-system directory in which the
     DMS resides.  Several DMSs may reside in the DM per-system directory.
     The one selected is the one for the current bootload at the AIM
     authorization of the caller.  If not specified, the default DMS is
     the DMS the process is currently using.  If not specified and the
     process is not currently using a DMS, an error message is printed and
     no action is performed.
  -reason STRING
     is the reason, STRING, why the DMS is being shut down.  This reason
     is ultimately part of the messages received by users of the DMS.  If
     not specified, a prompt is issued for the reason.  STRING can be no
     longer than 64 characters.  STRING must be quoted if it contains
     whitespace.
  -user_warning_time TIME, -uwtm TIME
     specifies the user-warning-time.  TIME may be absolute or relative to
     the time at which the dm_system_shutdown command is invoked.  TIME
     must be acceptable to the convert_date_to_binary_ subroutine.  If no
     user-warning-time is specified, the default is to use the config file
     begin_shutdown_delay to determine the user-warning-time, calculating
     backwrads in time.
  -begin_shutdown_delay DELAY, -bsd DELAY
     specifies the time period between the user-warning-time and the
     begin-shutdown-time.  DELAY must be in a form acceptable to the
     convert_date_to_binary_ subroutine.  If no begin-shutdown-time is
     specified, the default is to use the config file begin_shutdown_delay
     to determine the begin-shutdown-time.
  -begin_shutdown_time TIME, -bstm TIME
     specifies the begin-shutdown-time.  TIME may be absolute or relative
     to the time at which the dm_system_shutdown command is invoked.  TIME
     must be acceptable to the convert_date_to_binary_ subroutine.  If no
     begin-shutdown-time is specified, the default is to use the config
     file begin_shutdown_delay to determine the begin-shutdown-time.
  -user_shutdown_delay DELAY, -usd DELAY
     specifies the time period between the begin-shutdown-time and the
     user-shutdown-time.  DELAY must be in a form acceptable to the
     convert_date_to_binary_ subroutine.  If no user-shutdown-time is
     specified, the default is to use the config file user_shutdown_delay
     to determine the user-shutdown-time.
  -user_shutdown_time TIME, -ustm TIME
     specifies the user-shutdown-time.  TIME may be absolute or relative
     to the time at which the dm_system_shutdown command is invoked.  TIME
     must be acceptable to the convert_date_to_binary_ subroutine.  If no
     user-shutdown-time is specified, the default is to use the config
     file user_shutdown_delay to determine the user-shutdown-time.
  -user_bump_delay DELAY, -ubd DELAY
     specifies the time period between the user-shutdown-time and the
     user-bump-time.  DELAY must be in a form acceptable to the
     convert_date_to_binary_ subroutine.  If no user-bump-time is
     specified, the default is to use the config file user_bump_delay to
     determine the user-bump-time.
  -user_bump_time TIME, -ubtm TIME
     specifies the user-bump-time.  TIME may be absolute or relative to
     the time at which the dm_system_shutdown command is invoked.  TIME
     must be acceptable to the convert_date_to_binary_ subroutine.  If no
     times are specified via a -..._time control argument, the
     user-bump-time defaults to the scheduled Multics shutdown time.  If a
     time other than the user-bump-time is specified, the default is to
     use the config file user_bump_delay to determine the user-bump-time.
  -daemon_logout_delay DELAY, -dld DELAY
     specifies the time period between the user-bump-time and the
     daemon-logout-time.  DELAY must be in a form acceptable to the
     convert_date_to_binary_ subroutine.  If no daemon-logout-time is
     specified, the default is to use the config file daemon_logout_delay
     to determine the daemon-logout-time.
  -daemon_logout_time TIME, -dltm TIME
     specifies the daemon-logout-time.  TIME may be absolute or relative
     to the time at which the dm_system_shutdown command is invoked.  TIME
     must be acceptable to the convert_date_to_binary_ subroutine.  If no
     daemon-logout-time is specified, the default is to use the config
     file daemon_logout_delay to determine the daemon-logout-time.
  

  Notes on access requirements:  're' permission to dm_admin_gate_ is
  required to execute this command.


  Examples:

  Given:
     Multics shutdown scheduled for 8:00.
     All default delays are five minutes.

  dm_system_shutdown -bsd 20min

     Schedules shutdown with following times:
       user-warning:  7:30 (specified delay)
       begin-shutdown:  7:50 (default delay)
       user-shutdown:  7:55 (default delay)
       user-bump:  8:00 (default time)
       daemon-logout:  8:05 (default delay)

  dm_system_shutdown -uwtm 5:00 -ustm 6:10 -ubtm 6:00

     Schedules shutdown with following times:
       user-warning:  5:00 (specified time)
       begin-shutdown:  5:05 (default delay)
       user-shutdown:  6:10 (specified time)
       user-bump:  6:00 (specified time)
       daemon-logout:  6:05 (default delay)
*/

/* HISTORY:

Written by Matthew Pierret, 09/05/84.
Modified:
10/03/84 by Lee A. Newcomb:  to call dm_misc_util_$set_system_dir as this
	  entry is not privileged now and call it with a code arg.
10/04/84 by Lee A. Newcomb:  Set char strings that are tested to "" after
            unspec'ing the structure containing them, e.g.,
            arg_info.dm_system_directory.
10/29/84 by Lee A. Newcomb:  Fixed to not use dm_ prefix in dm_misc_util
            entries.
11/22/84 by Lee A. Newcomb:  Changed dm_misc_util_$(get set)_system_dir
	  to use correct calling sequences.
02/22/85 by Lee A. Newcomb:  Fixed the short names of the -*_time control args
            to all end with "tm" instead of "t" (e.g., -uwt --> -uwtm).
03/19/85 by S. Cox: Added dm_not_available_ handler.
*/

/* format: style2,ll79,indnoniterend,^indnoniterdo */
/* format: comcol50,indblkcom,indcomtxt */
%page;
dm_system_shutdown:
     proc ();

/* START OF DECLARATIONS */
/* Parameter */

	dcl     p_info_ptr		 ptr parm;
	dcl     p_sci_ptr		 ptr parm;

/* Automatic */

	dcl     arg_info_ptr	 ptr;
	dcl     arg_list_ptr	 ptr;
	dcl     accept_control_argument
				 bit (1) aligned;
	dcl     arg_idx		 fixed bin;
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     control_argument_idx	 fixed bin;
	dcl     is_active_function	 bit (1) aligned;
	dcl     number_of_args	 fixed bin;
	dcl     return_arg_len	 fixed bin (21);
	dcl     return_arg_ptr	 ptr;

	dcl     myname		 char (32);
	dcl     myversion		 char (32);
	dcl     1 my_arg_info	 aligned like arg_info;
	dcl     1 my_shutdown_info	 aligned like shutdown_info;

	dcl     code		 fixed bin (35) init (0);
	dcl     info_ptr		 ptr;
	dcl     sci_ptr		 ptr;
	dcl     this_is_a_standalone_invocation
				 bit (1) aligned;
	dcl     begin_shutdown_time_string
				 char (16);
	dcl     user_bump_time_string	 char (16);
	dcl     dummy_tm_shutdown_info_ptr
				 ptr;

/* Based */

	dcl     arg		 char (arg_len) based (arg_ptr);
	dcl     1 arg_info		 aligned based (arg_info_ptr),
		2 spec		 aligned like shutdown_spec,
		2 dm_system_directory
				 char (168) unal;

/* Builtin */

	dcl     (addr, hbound, index, length, min, null, rtrim, substr,
	        unspec)		 builtin;

/* Constant */

	dcl     (
	        YES		 init ("1"b),
	        NO		 init ("0"b)
	        )			 bit (1) aligned int static
				 options (constant);
	dcl     (
	        COMMAND_NAME	 init ("dm_system_shutdown"),
	        COMMAND_VERSION	 init ("1.0"),
	        REQUEST_NAME	 init ("shutdown"),
	        REQUEST_VERSION	 init ("1.0")
	        )			 char (32) int static
				 options (constant);
	dcl     ARGUMENT_TYPE	 (22) internal static
				 options (constant) char (64)
				 varying
				 init ("pathname", "pathname",
				 "reason", "reason", "time", "time",
				 "time", "time", "time delay",
				 "time delay", "time", "time",
				 "time delay", "time delay", "time",
				 "time", "time delay", "time delay",
				 "time", "time", "time delay",
				 "time delay");

	dcl     CONTROL_ARGUMENT	 (22) internal static
				 options (constant) char (64)
				 varying
				 init ("-dm_system_directory", "-dmsd",
				 "-reason", "-reason",
				 "-user_warning_time", "-uwtm",
				 "-begin_shutdown_time", "-bstm",
				 "-begin_shutdown_delay", "-bsd",
				 "-user_shutdown_time", "-ustm",
				 "-user_shutdown_delay", "-usd",
				 "-user_bump_time", "-ubtm",
				 "-user_bump_delay", "-ubd",
				 "-daemon_logout_time", "-dltm",
				 "-daemon_logout_delay", "-dld");


/* Condition */

	dcl     dm_not_available_	 condition;

/* Entry */

	dcl     absolute_pathname_	 entry (char (*), char (*),
				 fixed bin (35));
	dcl     convert_date_to_binary_
				 entry (char (*), fixed bin (71),
				 fixed bin (35));
	dcl     convert_date_to_binary_$relative
				 entry (char (*), fixed bin (71),
				 fixed bin (71), fixed bin (35));
	dcl     clock_		 entry () returns (fixed bin (71));
	dcl     cu_$arg_list_ptr	 entry (ptr);
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     dm_admin_util_$schedule_shutdown
				 entry (ptr, ptr);
	dcl     dm_misc_util_$get_system_dir
				 entry (char (*));
	dcl     dm_misc_util_$set_system_dir
				 entry (char (*));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr,
				 fixed bin (21));
	dcl     ssu_$destroy_invocation
				 entry (ptr);
	dcl     ssu_$print_message	 entry () options (variable);
	dcl     ssu_$return_arg	 entry (ptr, fixed bin,
				 bit (1) aligned, ptr, fixed bin (21));
	dcl     ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr,
				 entry, fixed bin (35));
	dcl     transaction_manager_$user_shutdown
				 entry (ptr, ptr, fixed bin (35));

/* External */

	dcl     dm_error_$dm_shutdown_not_sched
				 ext fixed bin (35);
	dcl     dm_error_$system_not_initialized
				 fixed bin (35) ext static;
	dcl     error_table_$active_function
				 ext fixed bin (35);
	dcl     error_table_$badopt	 ext fixed bin (35);
	dcl     error_table_$noarg	 ext fixed bin (35);

/* END OF DECLARATIONS */
%page;
	myname = COMMAND_NAME;
	myversion = COMMAND_VERSION;
	this_is_a_standalone_invocation = "1"b;
	call cu_$arg_list_ptr (arg_list_ptr);
	call ssu_$standalone_invocation (sci_ptr, myname, myversion,
	     arg_list_ptr, ABORT_ENTRY, code);

	on dm_not_available_
	     call ssu_$abort_line (sci_ptr, dm_error_$system_not_initialized)
		;

	go to JOIN;

shutdown_request:
     entry (p_sci_ptr, p_info_ptr);

	myname = REQUEST_NAME;
	myversion = REQUEST_VERSION;
	this_is_a_standalone_invocation = "0"b;
	sci_ptr = p_sci_ptr;
	info_ptr = p_info_ptr;
	go to JOIN;

JOIN:				         /* Process arguments. */
	call ssu_$return_arg (sci_ptr, number_of_args, is_active_function,
	     return_arg_ptr, return_arg_len);

	if is_active_function
	then call ssu_$abort_line (sci_ptr, error_table_$active_function,
		myname);

	arg_info_ptr = addr (my_arg_info);
	unspec (arg_info) = ""b;
	arg_info.spec.version = SHUTDOWN_SPEC_VERSION_1;
	arg_info.spec.reason = "";	         /* so if x = "" works */
	arg_info.dm_system_directory = "";     /* '' */

	accept_control_argument = YES;
	control_argument_idx = -1;

ARG_PROCESSING_LOOP:
	do arg_idx = 1 to number_of_args;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_len);
	     if accept_control_argument = YES
	     then call PROCESS_CONTROL_ARGUMENT (arg, arg_info_ptr,
		     control_argument_idx, accept_control_argument);
	     else if index (arg, "-") ^= 1
	     then call PROCESS_ARGUMENT (arg, arg_info_ptr,
		     control_argument_idx, accept_control_argument);
	     else if (CONTROL_ARGUMENT_INDEX (arg) = -1)
	     then call PROCESS_ARGUMENT (arg, arg_info_ptr,
		     control_argument_idx, accept_control_argument);
	     else call ssu_$abort_line (sci_ptr, error_table_$noarg,
		     "^a must be followed by a^[n^] ^a.",
		     CONTROL_ARGUMENT (control_argument_idx),
		     (
		     index ("aeiouh",
		     substr (ARGUMENT_TYPE (control_argument_idx), 1, 1))
		     > 0), ARGUMENT_TYPE (control_argument_idx));
	end ARG_PROCESSING_LOOP;

	if control_argument_idx >= 0 & accept_control_argument = NO
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"^a must be followed by a^[n^] ^a.",
		CONTROL_ARGUMENT (control_argument_idx),
		(
		index ("aeiouh",
		substr (ARGUMENT_TYPE (control_argument_idx), 1, 1)) > 0),
		ARGUMENT_TYPE (control_argument_idx));


	if arg_info.dm_system_directory = ""
	then call dm_misc_util_$get_system_dir (arg_info.dm_system_directory)
		;
	else do;
	     dummy_tm_shutdown_info_ptr = null ();
	     call transaction_manager_$user_shutdown (
		get_system_free_area_ (), dummy_tm_shutdown_info_ptr, code)
		;
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		     "^/Could not shutdown use of a Data Management system."
		     );
	     call dm_misc_util_$set_system_dir (arg_info.dm_system_directory)
		;
	     end;
	;

	unspec (my_shutdown_info) = ""b;
	my_shutdown_info.version = SHUTDOWN_INFO_VERSION_1;

	call dm_admin_util_$schedule_shutdown (addr (arg_info.spec),
	     addr (my_shutdown_info));

	if my_shutdown_info.output_flags.no_time_specified
	then call ssu_$abort_line (sci_ptr, dm_error_$dm_shutdown_not_sched,
		"No time was specified, and there is no Multics shutdown scheduled."
		);
	else if my_shutdown_info.output_flags.times_have_changed
	then do;
	     call date_time_ (my_shutdown_info.times.begin_shutdown_time,
		begin_shutdown_time_string);
	     call date_time_ (my_shutdown_info.times.user_bump_time,
		user_bump_time_string);
	     call ssu_$print_message (sci_ptr, 0,
		"DM system shutdown scheduled to begin at ^a, to bump users at ^a.",
		begin_shutdown_time_string, user_bump_time_string);
	     end;
	else call ssu_$print_message (sci_ptr,
		dm_error_$dm_shutdown_not_sched,
		"^/The current Multics shutdown time is earlier than the specified time."
		);

MAIN_RETURN:
	call CLEANUP ();
	return;


ABORT_ENTRY:
     procedure ();
	go to MAIN_RETURN;
     end ABORT_ENTRY;

CLEANUP:
     procedure ();
	if this_is_a_standalone_invocation
	then call ssu_$destroy_invocation (sci_ptr);
	else ;
     end CLEANUP;
%page;
PROCESS_ARGUMENT:
     proc (pa_p_arg, pa_p_arg_info_ptr, pa_p_control_argument_idx,
	pa_p_accept_control_argument);

	dcl     pa_p_arg		 char (*) parm;
	dcl     pa_p_arg_info_ptr	 ptr parm;
	dcl     pa_p_control_argument_idx
				 fixed bin parm;
	dcl     pa_p_accept_control_argument
				 bit (1) aligned parm;

	dcl     pa_code		 fixed bin (35);
	dcl     pa_computed_time	 fixed bin (71);
	dcl     pa_current_time	 fixed bin (71);

	pa_code = 0;

	goto ARGUMENT (pa_p_control_argument_idx);

ARGUMENT (1):			         /* -dm_system_directory */
ARGUMENT (2):			         /* -dmsd */
	call absolute_pathname_ ((pa_p_arg),
	     pa_p_arg_info_ptr -> arg_info.dm_system_directory, pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (3):			         /* -reason */
ARGUMENT (4):			         /* -reason */
	pa_p_arg_info_ptr -> arg_info.spec.reason =
	     substr (pa_p_arg, 1, min (length (rtrim (pa_p_arg)), 64));

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (5):			         /* -user_warning_time */
ARGUMENT (6):			         /* -uwtm */
	call convert_date_to_binary_ (pa_p_arg,
	     pa_p_arg_info_ptr -> arg_info.spec.times.user_warning_time,
	     pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (7):			         /* -begin_shutdown_time */
ARGUMENT (8):			         /* -bstm */
	call convert_date_to_binary_ (pa_p_arg,
	     pa_p_arg_info_ptr -> arg_info.spec.times.begin_shutdown_time,
	     pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (9):			         /* -begin_shutdown_delay */
ARGUMENT (10):			         /* -bsd */
	pa_current_time = clock_ ();
	call convert_date_to_binary_$relative (pa_p_arg, pa_computed_time,
	     pa_current_time, pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);
	pa_p_arg_info_ptr -> arg_info.spec.delays.begin_shutdown_delay =
	     pa_computed_time - pa_current_time;

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (11):			         /* -user_shutdown_time */
ARGUMENT (12):			         /* -ustm */
	call convert_date_to_binary_ (pa_p_arg,
	     pa_p_arg_info_ptr -> arg_info.spec.times.user_shutdown_time,
	     pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (13):			         /* -user_shutdown_delay */
ARGUMENT (14):			         /* -usd */
	pa_current_time = clock_ ();
	call convert_date_to_binary_$relative (pa_p_arg, pa_computed_time,
	     pa_current_time, pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);
	pa_p_arg_info_ptr -> arg_info.spec.delays.user_shutdown_delay =
	     pa_computed_time - pa_current_time;

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (15):			         /* -user_bump_time */
ARGUMENT (16):			         /* -ubtm */
	call convert_date_to_binary_ (pa_p_arg,
	     pa_p_arg_info_ptr -> arg_info.spec.times.user_bump_time,
	     pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (17):			         /* -user_bump_delay */
ARGUMENT (18):			         /* -ubd */
	pa_current_time = clock_ ();
	call convert_date_to_binary_$relative (pa_p_arg, pa_computed_time,
	     pa_current_time, pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);
	pa_p_arg_info_ptr -> arg_info.spec.delays.user_bump_delay =
	     pa_computed_time - pa_current_time;

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (19):			         /* -daemon_logout_time */
ARGUMENT (20):			         /* -dltm */
	call convert_date_to_binary_ (pa_p_arg,
	     pa_p_arg_info_ptr -> arg_info.spec.times.daemon_logout_time,
	     pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;

ARGUMENT (21):			         /* -daemon_logout_delay */
ARGUMENT (22):			         /* -dld */
	pa_current_time = clock_ ();
	call convert_date_to_binary_$relative (pa_p_arg, pa_computed_time,
	     pa_current_time, pa_code);
	if pa_code ^= 0
	then call ssu_$abort_line (sci_ptr, pa_code, pa_p_arg);
	pa_p_arg_info_ptr -> arg_info.spec.delays.daemon_logout_delay =
	     pa_computed_time - pa_current_time;

	pa_p_control_argument_idx = -1;
	pa_p_accept_control_argument = "1"b;
	return;


     end PROCESS_ARGUMENT;
%page;
PROCESS_CONTROL_ARGUMENT:
     proc (pca_p_arg, pca_p_arg_info_ptr, pca_p_control_argument_idx,
	pca_p_accept_control_argument);


	dcl     pca_p_arg		 char (*) parm;
	dcl     pca_p_arg_info_ptr	 ptr parm;
	dcl     pca_p_control_argument_idx
				 fixed bin parm;
	dcl     pca_p_accept_control_argument
				 bit (1) aligned parm;

	pca_p_control_argument_idx = CONTROL_ARGUMENT_INDEX (pca_p_arg);

	go to CONTROL_ARGUMENT (pca_p_control_argument_idx);

CONTROL_ARGUMENT (-1):		         /* not a control argument */
	call ssu_$abort_line (sci_ptr, error_table_$badopt, pca_p_arg);

CONTROL_ARGUMENT (1):		         /* -dm_system_directory */
CONTROL_ARGUMENT (2):		         /* -dmsd */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (3):		         /* -reason */
CONTROL_ARGUMENT (4):		         /* -reason */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (5):		         /* -user_warning_time */
CONTROL_ARGUMENT (6):		         /* -uwtm */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (7):		         /* -begin_shutdown_time */
CONTROL_ARGUMENT (8):		         /* -bstm */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (9):		         /* -begin_shutdown_delay */
CONTROL_ARGUMENT (10):		         /* -bsd */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (11):		         /* -user_shutdown_time */
CONTROL_ARGUMENT (12):		         /* -ustm */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (13):		         /* -user_shutdown_delay */
CONTROL_ARGUMENT (14):		         /* -usd */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (15):		         /* -user_bump_time */
CONTROL_ARGUMENT (16):		         /* -ubtm */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (17):		         /* -user_bump_delay */
CONTROL_ARGUMENT (18):		         /* -ubd */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (19):		         /* -daemon_logout_time */
CONTROL_ARGUMENT (20):		         /* -dltm */
	pca_p_accept_control_argument = "0"b;
	return;
CONTROL_ARGUMENT (21):		         /* -daemon_logout_delay */
CONTROL_ARGUMENT (22):		         /* -dld */
	pca_p_accept_control_argument = "0"b;
	return;

     end PROCESS_CONTROL_ARGUMENT;


CONTROL_ARGUMENT_INDEX:
     proc (cai_p_arg) returns (fixed bin);

	dcl     cai_p_arg		 char (*);
	dcl     cai_control_argument_idx
				 fixed bin;

	do cai_control_argument_idx = 1 to hbound (CONTROL_ARGUMENT, 1)
	     while (CONTROL_ARGUMENT (cai_control_argument_idx) ^= cai_p_arg)
	     ;
	end;
	if cai_control_argument_idx > hbound (CONTROL_ARGUMENT, 1)
	then return (-1);
	else return (cai_control_argument_idx);

     end CONTROL_ARGUMENT_INDEX;
%page;
%include dm_shutdown_spec;

     end dm_system_shutdown;




		    dm_translate_system_config_.rd  03/17/86  1519.8re  03/17/86  1430.1      187497



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

/*  DESCRIPTION:
	dm_translate_system_config_ - program to extract DMS configuration
     data from an ascii segment and return a pointer to a structure which
     summarizes the configuration parameters.
*/

/* HISTORY:
Written by M. Pandolf, December 1982.
Modified:
03/15/83 by M. Pandolf:  for default before journal keywords and for
	  logging process terminations.
05/05/83 by L. A. Newcomb:  added recovery_check_mode and fixed the old
	  subsystem_inhibit to be subsystem_disposition.  NOTE:  work
	  needs to be done on error reporting for duplicate settings,
	  such as specifying "^recover, recovery_check_mode".
11/04/83 by M. Pandolf: to check to see if default before journal ends in ".bj"
05/29/84 by Lindsey Spratt: Changed to use version 2 dm_system_config.
	  Removed several elements of the config, to whit; maximum
	  number_of_before_journals, inhibit subsystem, and daemon error
	  trace.  None of these were in use.
06/12/84 by Lindsey Spratt: Added code for shutdown_delay. Changed to check
	  for before_journal_size > 2 instead of 0.
*/
/* format: style4,indattr,ifthenstmt,ifthen,^indcomtxt,idind33 */
%page;
/*
   The DM configuration file contains information used at data management initialization
   time to configure the system to site dependent parameters.  These
   parameters override the values built in to the CDS named
   "dm_system_data_".

   The form of the DM configuration file is as follows:

   <DM config file> ::= [<spec>]...<end statement>
   <spec> ::=           <default before journal size> |
                        <maximum number of processes> |
                        <maximum number of transactions> |
                        <default before journal> |
                        <previous bootload status> |
                        <current bootload enable> |
                        <daemon idle timeout> |
		    <shutdown delay> |
                        <daemon log proc terms>
   <default before journal size> ::=
                        system_before_journal_size: <decimal integer>;
   <maximum number of processes> ::=
                        max_processes: <decimal integer>;
   <maximum number of transactions> ::=
                        max_transactions: <decimal integer>;
   <default before journal> ::=
                        default_before_journal: <path spec>;
   <previous bootload status> ::=
                        prev_bootload_status: <status option>[,<status option>]...;
   <current bootload enable> ::=
                        current_bootload_enable: force | ^force;
   <daemon idle timeout local> ::=
                        idle_timeout: <decimal integer>;
   <shutdown delay> ::=
		    shutdown_delay: <decimal integer>;
   <daemon log proc terms> ::=
                        log_proc_terms: on | off;
   <end statement> ::=  end;

   <path spec> ::=      dir=<path> | entry=<segment name> |
		    dir=<path>,entry=<segment name> |
                        entry=<segment name>,dir=<path> | <null string>

   <status option> ::=  hold | adopt | recover | recovery_check_mode | ^hold | ^adopt | ^recover | ^recovery_check_mode

   <path> ::=           <absolute pathname> | aim_dir | bootload_dir.
/*++

BEGIN
	/ system_before_journal_size : <decimal-integer> ; /
		LEX(2) [	if token.Nvalue > 2
			then dm_system_config.default_bj_size = token.Nvalue;
			else call ERROR(4)]
		LEX(2) / BEGIN \

	/ system_before_journal_size <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ system_before_journal_size <no-token> /
		ERROR(8) / BEGIN \

	/ max_processes : <decimal-integer> ; /
		LEX(2) [	if token.Nvalue > 0
			then dm_system_config.max_n_proc = token.Nvalue;
			else call ERROR(4)]
		LEX(2) / BEGIN  \

	/ max_processes <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ max_processes <no-token> /
		ERROR(8) / BEGIN \

	/ max_transactions : <decimal-integer> ; /
		LEX(2) [	if token.Nvalue > 0
			then dm_system_config.max_n_txn = token.Nvalue;
			else call ERROR(4)]
		LEX(2) / BEGIN  \

	/ max_transactions <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ max_transactions <no-token> /
		ERROR(8) / BEGIN \

	/ idle_timeout : <decimal-integer> ; /
		LEX(2) [	if token.Nvalue > 0
			then dm_system_config.idle_timeout = token.Nvalue;
			else call ERROR(4)]
		LEX(2) / BEGIN  \

	/ idle_timeout <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ idle_timeout <no-token> /
		ERROR(8) / BEGIN \

	/ shutdown_delay : <date_time_offset> ; /
		LEX(2) [	dm_system_config.shutdown_delay = convert_date_time_offset();
]
		LEX(2) / BEGIN  \

	/ shutdown_delay <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ shutdown_delay <no-token> /
		ERROR(8) / BEGIN \

	/ default_before_journal : /
		LEX(2) / path_spec \

	/ prev_bootload_status : /
		[save_prev_dm_disp = dm_system_config.prev_dm_disp]
		LEX(2) / status_spec \

	/ current_bootload_enable : force ; /
		[dm_system_config.curr_dm_enable = DM_FORCE_ENABLE_NEW_BOOTLOAD] LEX(4) / BEGIN \

	/ current_bootload_enable : ^force ; /
		[dm_system_config.curr_dm_enable = DM_DO_NOT_FORCE_ENABLE_NEW_BOOTLOAD] LEX(5) / BEGIN \

	/ current_bootload_enable <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ current_bootload_enable <no-token> /
		ERROR(8) / BEGIN \

	/ log_proc_terms : on ; /
		[dm_system_config.log_proc_terms = "1"b] LEX(4) / BEGIN \

	/ log_proc_terms : off ; /
		[dm_system_config.log_proc_terms = "0"b] LEX(4) / BEGIN \

	/ log_proc_terms <any-token> /
		LEX(2) ERROR(4) NEXT_STMT / BEGIN \

	/ log_proc_terms <no-token> /
		ERROR(8) / BEGIN \

	/ end ; <no-token> /
		return_table / RETURN \

	/ end ; <any-token> /
		ERROR(2) return_table / RETURN \

	/ <any-token> /
		ERROR(1) NEXT_STMT / BEGIN \

	/ <no-token> /
		ERROR(3) return_table / RETURN \

path_spec

	/ ; /
		LEX(1) / BEGIN \

	/ dir = <absolute_path> ; /
		LEX(2) [dm_system_config.default_bj.dir = token_value]
		LEX(2) / BEGIN \

	/ dir = <absolute_path> , /
		LEX(2) [dm_system_config.default_bj.dir = token_value]
		LEX(2) / path_spec \

	/ dir = <any-token> /
		LEX(2) ERROR(9) NEXT_STMT / BEGIN \

	/ entry = <before_journal_name> ; /
		LEX(2) [dm_system_config.default_bj.entry = token_value]
		LEX(2) / BEGIN \

	/ entry = <before_journal_name> , /
		LEX(2) [dm_system_config.default_bj.entry = token_value]
		LEX(2) / path_spec \

	/ entry = <any-token> /
		LEX(2) ERROR(10) NEXT_STMT / BEGIN \

	/ <any-token> /
		ERROR(4) NEXT_STMT / BEGIN \

	/ <no-token> /
		ERROR(8) / BEGIN \

status_spec

	/ hold ; /
		[dm_system_config.prev_dm_disp.hold = DM_HOLD_OLD_BOOTLOAD_DIRECTORY]
		LEX(2) / BEGIN \

	/ hold , /
		[dm_system_config.prev_dm_disp.hold = DM_HOLD_OLD_BOOTLOAD_DIRECTORY]
		LEX(2) / status_spec \

	/ hold <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ ^hold ; /
		[dm_system_config.prev_dm_disp.hold = DM_DO_NOT_HOLD_OLD_BOOTLOAD_DIRECTORY]
		LEX(3) / BEGIN \

	/ ^hold , /
		[dm_system_config.prev_dm_disp.hold = DM_DO_NOT_HOLD_OLD_BOOTLOAD_DIRECTORY]
		LEX(3) / status_spec \

	/ ^hold <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ adopt ; /
		[dm_system_config.prev_dm_disp.adopt = DM_ADOPT_OLD_BOOTLOAD]
		LEX(2) / BEGIN \

	/ adopt , /
		[dm_system_config.prev_dm_disp.adopt = DM_ADOPT_OLD_BOOTLOAD]
		LEX(2) / status_spec \

	/ adopt <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ ^adopt ; /
		[dm_system_config.prev_dm_disp.adopt = DM_DO_NOT_ADOPT_OLD_BOOTLOAD]
		LEX(3) / BEGIN \

	/ ^adopt , /
		[dm_system_config.prev_dm_disp.adopt = DM_DO_NOT_ADOPT_OLD_BOOTLOAD]
		LEX(3) / status_spec \

	/ ^adopt <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ recover ; /
		[dm_system_config.prev_dm_disp.recover = DM_RECOVER_OLD_BOOTLOAD]
		LEX(2) / BEGIN \

	/ recover , /
		[dm_system_config.prev_dm_disp.recover = DM_RECOVER_OLD_BOOTLOAD]
		LEX(2) / status_spec \

	/ recover <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ ^recover ; /
		[dm_system_config.prev_dm_disp.recover = DM_DO_NOT_RECOVER_OLD_BOOTLOAD]
		LEX(3) / BEGIN \

	/ ^recover , /
		[dm_system_config.prev_dm_disp.recover = DM_DO_NOT_RECOVER_OLD_BOOTLOAD]
		LEX(3) / status_spec \

	/ ^recover <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ recovery_check_mode ; /
		[dm_system_config.prev_dm_disp.recovery_check_mode = DM_RECOVERY_CHECK_MODE_ON]
		LEX(2) / BEGIN \

	/ recovery_check_mode , /
		[dm_system_config.prev_dm_disp.recovery_check_mode = DM_RECOVERY_CHECK_MODE_ON]
		LEX(2) / status_spec \

	/ recovery_check_mode <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ ^recovery_check_mode ; /
		[dm_system_config.prev_dm_disp.recovery_check_mode = DM_RECOVERY_CHECK_MODE_OFF]
		LEX(3) / BEGIN \

	/ ^recovery_check_mode , /
		[dm_system_config.prev_dm_disp.recovery_check_mode = DM_RECOVERY_CHECK_MODE_OFF]
		LEX(3) / status_spec \

	/ ^recovery_check_mode <any-token> /
		[dm_system_config.prev_dm_disp = save_prev_dm_disp]
		LEX(1) ERROR(6) NEXT_STMT / BEGIN \

	/ <any-token> /
		ERROR(4) NEXT_STMT / BEGIN \

	/ <no-token> /
		ERROR(8) / BEGIN \


++*/

/* format: style2,ind3 */
dm_translate_system_config_:
   procedure (p_system_config_file_ptr, p_system_config_file_len, p_long_sw, p_area_ptr, p_system_config_ptr, p_code);

%page;

/* DECLARATIONS */

/* Parameter */

      dcl	    p_system_config_file_ptr
			       pointer parameter;	/* INPUT - pointer to ascii data */
      dcl	    p_system_config_file_len
			       fixed bin (21) parameter;
						/* INPUT - length of ascii data in bytes */
      dcl	    p_long_sw	       bit (1) aligned parameter;
						/* INPUT - true if errors to be printed out */
      dcl	    p_area_ptr	       pointer parameter;	/* INPUT - pointer to area where site data to be allocated */
      dcl	    p_system_config_ptr    pointer parameter;	/* OUTPUT - pointer to structure */
      dcl	    p_code	       fixed bin (35) parameter;
						/* OUTPUT - system status code */

/* Automatic */

      dcl	    code		       fixed bin (35);
      dcl	    breaks	       char (128) varying aligned;
      dcl	    ignored_breaks	       char (128) varying aligned;
      dcl	    lex_delims	       char (128) varying aligned;
      dcl	    lex_control_chars      char (128) varying aligned;
      dcl	    byte_count	       fixed bin (21);
      dcl	    source_ptr	       pointer;
      dcl	    temp_storage_ptr       pointer;
      dcl	    Pfirst_stmt_descriptor pointer;
      dcl	    Pfirst_token_descriptor
			       pointer;
      dcl	    abs_path	       char (168);
      dcl	    1 my_dm_system_config  aligned like dm_system_config;
      dcl	    1 save_prev_dm_disp    aligned like dm_system_config_info.prev_dm_disp;

/* Static, Internal */

      dcl	    1 error_control_table  dimension (10) internal static,
	      2 severity	       fixed bin (17) unaligned init (2, 1, 2, 2, 4, 2, 2, 3, 2, 2),
	      2 Soutput_stmt       bit (1) unaligned init ((10) (1)"1"b),
	      2 message	       char (96) varying
			       init ("An unknown statement has been encountered:  statement ignored.",
			       "Text follows the end statement and is being ignored.",
			       "The end statement is missing:  one has been supplied.",
			       """^a"" is not a valid keyword option:  statement ignored.",
			       "The end statement has been prematurely encountered.",
			       "An option delimiter is missing:  statement ignored.", "The option list is invalid.",
			       "The statement has prematurely ended.",
			       """^a"" is not a valid directory name:  statement ignored.",
			       """^a"" is not a valid before journal name:  statement ignored."),
	      2 brief_message      char (48) varying
			       init ("Unknown statement.", "Text follows the end statement.",
			       "Missing end statement.", "Invalid option.", "Premature end statement.",
			       "Missing option delimiter.", "Invalid option list.", "Premature statement end.",
			       "Invalid directory name.", "Invalid before journal name.");

/* Static, External */

      dcl	    error_table_$no_stmt_delim
			       fixed bin (35) ext static;
      dcl	    error_table_$translation_failed
			       fixed bin (35) ext static;
      dcl	    error_table_$improper_data_format
			       fixed bin (35) ext static;
      dcl	    error_table_$notalloc  fixed bin (35) ext static;

/* Based */

      dcl	    caller_area	       area based (p_area_ptr);

/* Constant */

      dcl	    ME		       char (32) aligned internal static options (constant)
			       init ("dm_translate_system_config_");

/* Entry */

      dcl	    absolute_pathname_     entry (char (*), char (*), fixed bin (35));
      dcl	    convert_date_to_binary_
			       entry (char (*), fixed bin (71), fixed bin (35));
      dcl	    dm_gen_checksum_       entry (ptr, fixed bin (18)) returns (fixed bin (35));
      dcl	    get_temp_segment_      entry (char (*) aligned, ptr, fixed bin (35));
      dcl	    lex_string_$init_lex_delims
			       entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var,
			       char (*) var, char (*) var, char (*) var);
      dcl	    lex_string_$lex	       entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*),
			       char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var,
			       ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);
      dcl	    translator_temp_$get_segment
			       entry (char (*) aligned, ptr, fixed bin (35));
      dcl	    translator_temp_$release_all_segments
			       entry (ptr, fixed bin (35));
      dcl	    release_temp_segment_  entry (char (*) aligned, ptr, fixed bin (35));

/* Builtin */

      dcl	    null		       builtin;
      dcl	    substr	       builtin;
      dcl	    collate	       builtin;
      dcl	    addr		       builtin;
      dcl	    size		       builtin;
      dcl	    rtrim		       builtin;

/* Condition */

      dcl	    cleanup	       condition;
      dcl	    area		       condition;


/* END DECLARATIONS */

%page;

/* BEGIN CODE */

/* initialize some values */

      source_ptr = p_system_config_file_ptr;
      byte_count = p_system_config_file_len;
      temp_storage_ptr = null ();
      p_code = error_table_$translation_failed;

      error_control_table.Soutput_stmt (*) = p_long_sw;

/* set up cleanup handler */

      on cleanup
         begin;
	  call translator_temp_$release_all_segments (temp_storage_ptr, code);
	  call release_temp_segment_ (ME, dm_system_config_ptr, code);
	  goto dm_translate_system_config_exit;
         end;

/* get temp space for translation as required by rd */

      call translator_temp_$get_segment (ME, temp_storage_ptr, code);
      if code ^= 0
      then call dm_translate_system_config_abort ();

/* set up the lex function */

      breaks = substr (collate (), 1, 33) || ",:=^" || substr (collate (), 128, 1);
      ignored_breaks = substr (collate (), 1, 8) || substr (collate (), 10, 24) || substr (collate (), 128, 1);

      call
         lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, breaks, ignored_breaks, lex_delims,
         lex_control_chars);

/* initiate the defaults in the config structure */

      dm_system_config_ptr = addr (my_dm_system_config);

      dm_system_config.version = DM_CONFIG_VERSION_2;
      dm_system_config.idle_timeout = 0;
      dm_system_config.shutdown_delay = 0;
      dm_system_config.log_proc_terms = "1"b;
      dm_system_config.lock = ""b;
      dm_system_config.max_n_txn = 0;
      dm_system_config.max_n_proc = 0;
      dm_system_config.default_bj_size = 0;
      dm_system_config.default_bj.dir = "";
      dm_system_config.default_bj.entry = "";
      dm_system_config.prev_dm_disp.adopt = DM_ADOPT_OLD_BOOTLOAD;
      dm_system_config.prev_dm_disp.hold = DM_DO_NOT_HOLD_OLD_BOOTLOAD_DIRECTORY;
      dm_system_config.prev_dm_disp.recover = DM_RECOVER_OLD_BOOTLOAD;
      dm_system_config.prev_dm_disp.recovery_check_mode = DM_RECOVERY_CHECK_MODE_OFF;
      dm_system_config.curr_dm_enable = DM_DO_NOT_FORCE_ENABLE_NEW_BOOTLOAD;

/* call subroutine to lex the dsdt file */

      call
         lex_string_$lex (source_ptr, byte_count, 0, temp_storage_ptr, "1000"b, """", """", "/*", "*/", ";", breaks,
         ignored_breaks, lex_delims, lex_control_chars, Pfirst_stmt_descriptor, Pfirst_token_descriptor, code);
      if ^(code = 0 | code = error_table_$no_stmt_delim)
      then
         do;
	  call dm_translate_system_config_abort ();
         end;

      Pthis_token = Pfirst_token_descriptor;

      call SEMANTIC_ANALYSIS ();

      call translator_temp_$release_all_segments (temp_storage_ptr, code);
      call release_temp_segment_ (ME, dm_system_config_ptr, code);

dm_translate_system_config_exit:
      return;

/* BEGIN RELATIVE FUNCTIONS */

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

/*
   this function returns true if the current token is either an absolute
   or one of the reserved pathname keywords "aim_dir" or "bootload_dir"
*/

      if token_value = "aim_dir" | token_value = "bootload_dir"
      then return ("1"b);

      if substr (token_value, 1, 1) ^= ">"
      then return ("0"b);

      call absolute_pathname_ (token_value, abs_path, code);
      if code ^= 0
      then return ("0"b);
      else return ("1"b);

   end absolute_path;

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

      dcl	    dto_convert	       bit (1) aligned init ("0"b);
      dcl	    dto_code	       fixed bin (35) init (0);
      dcl	    dto_constant_time_str  char (32) varying init ("January 1, 1980 9am");
      dcl	    dto_new_time_str       char (64) varying init ("");
      dcl	    dto_constant_time      fixed bin (71) init (0);
      dcl	    dto_new_time	       fixed bin (71) init (0);

      goto DTO_JOIN;
convert_date_time_offset:
   entry () returns (fixed bin (71));
      dto_convert = "1"b;
DTO_JOIN:
      dto_new_time_str = dto_constant_time_str || " + " || token_value;
      call convert_date_to_binary_ ((dto_new_time_str), dto_new_time, dto_code);
      if ^dto_convert
      then if dto_code ^= 0
	 then return ("0"b);
	 else return ("1"b);
      else if dto_code ^= 0
      then
         do;
	  call
	     sub_err_ (dto_code, ME, ACTION_DEFAULT_RESTART, null, 0, "^/Unable to convert ^a to its binary form.",
	     token_value);
	  return (0);
         end;
      call convert_date_to_binary_ ((dto_constant_time_str), dto_constant_time, dto_code);
      if dto_code ^= 0
      then
         do;
	  call
	     sub_err_ (dto_code, ME, ACTION_DEFAULT_RESTART, null, 0, "^/Unable to convert ^a to its binary form.",
	     dto_new_time_str);
	  return (0);
         end;

      return (dto_new_time - dto_constant_time);

   end date_time_offset;



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

/*
   this function returns true if the token is comprised of letters, digits,
   the underscore, and the period.  additionally, the token must end in
   ".bj".
*/

      if (token.Lvalue < 1) | (token.Lvalue > 32)
      then return ("0"b);

      if verify (token_value, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_.") ^= 0
      then return ("0"b);

      if substr (reverse (rtrim (token_value)), 1, 3) ^= "jb."
      then return ("0"b);

      return ("1"b);


   end before_journal_name;


/* BEGIN ACTION PROCEDURES */

return_table:
   procedure ();

      if p_area_ptr ^= null ()
      then
         do;

	  dm_system_config.checksum = dm_gen_checksum_ (dm_system_config_ptr, size (dm_system_config_info) - 1);

	  on area
	     begin;
	        code = error_table_$notalloc;
	        call dm_translate_system_config_abort ();
	     end;

	  allocate dm_system_config in (caller_area) set (p_system_config_ptr);

	  revert area;

	  p_system_config_ptr -> dm_system_config = dm_system_config_ptr -> dm_system_config;

         end;

      if MERROR_SEVERITY < 3
      then p_code = 0;

      return;

   end return_table;

dm_translate_system_config_abort:
   procedure ();

      p_code = code;
      call translator_temp_$release_all_segments (temp_storage_ptr, code);

      goto dm_translate_system_config_exit;

   end dm_translate_system_config_abort;
%page;
%include dm_system_config;
%page;
%include sub_err_flags;





		    dm_user_shutdown.pl1            04/04/85  1114.9re  04/04/85  0824.8       79515



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

/* DESCRIPTION:

	The dm_user_shutdown command terminates a process' usage of a
     Data Management System.  It is a direct interface to the entry
     transacton_manager_$user_shutdown.  All information returned from the
     subroutine call will be written to the user_output I/O switch.  If an
     error occurs, ONE call to com_err_ will be made at the end of the
     normal output.

     02/20/85 dm_user_shutdown

     Syntax as a command:  dm_user_shutdown

     Function: removes the process invoking it from the current invocation
     of the data management system (DMS).

     Notes: All user process references to per-process and per-system data
     are invalidated to permit subsequent reentry to DMS.  If a transaction
     is in progress in the process when you issue the command, the DM
     Daemon (Data_Management.Daemon) rolls it back automatically.

     Normally all processes using data management are shut down as part of
     a data management system shutdown, with no explicit user intervention.
     
     This command is part of the command level interface to Multics data
     management.  It is intended for use in a test environment or for
     debugging purposes.
*/

/* HISTORY:

Written by L. A. Newcomb, 03/09/84.
Modified:
05/16/84 by L. A. Newcomb:  fixed to pass user_shutdown_status_code to
            tm_$user_shutdown instead of another code value to stop stack
            garbage from staying in former; made to understand that only
	  TDT entries with active transactions are reported back; added
	  HISI pnotice.
03/19/85 by S. Cox: Added dm_not_available_ handler.
*/
/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo,^inddcls,dclind5,idind35,linecom */
%page;
dm_user_shutdown:
   proc ();

/* DECLARATIONS */

/* Parameter */
/* Automatic */
dcl  (
     accept_control_argument		bit (1) aligned init ("0"b),
     arg_list_ptr			ptr init (null),
     code				fixed bin (35) init (0),
     display_messages		bit (1) aligned init (YES),
     err_msg			char (100) aligned init (""),
     finish_started_freeing_structures	bit (1) aligned init (NO),
     force_interpretation_as_argument	bit (1) aligned init (NO),
     is_active_function		bit (1) aligned init (NO),
     number_of_args			fixed bin init (-1),
     sci_ptr			ptr init (null),
     shut_info_index		fixed bin init (0)
     )				automatic;

/* Based */
/* Builtin */
dcl  (addr, bin, null)		builtin;

/* Condition */
dcl  (cleanup, dm_not_available_)	condition;

/* Constant */
dcl  (
     IOA_GENERAL_RS_NO_NEW_LINE	bit (1) aligned init (""b),
     IOA_GENERAL_RS_DONT_PAD		bit (1) aligned init (""b),
     NO				bit (1) aligned init ("0"b),
     SSU_INVOCATION_ERR_MSG		char (49)
				init (
				"Cannot establish standalone subsystem invocation."
				),
     YES				bit (1) aligned init ("1"b),
     myname			init ("dm_user_shutdown") char (16)
     )				internal static options (constant);

/* Entry */
dcl  (
     com_err_			entry options (variable),
     convert_status_code_		entry (fixed bin (35),
				char (8) aligned, char (100) aligned),
     cu_$arg_list_ptr		entry (ptr),
     get_dm_free_area_		entry () returns (ptr),
     ioa_				entry () options (variable),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned),
     ssu_$abort_line		entry () options (variable),
     ssu_$destroy_invocation		entry (ptr),
     ssu_$return_arg		entry (ptr, fixed bin, bit (1) aligned,
				ptr, fixed bin (21)),
     ssu_$standalone_invocation	entry (ptr, char (*), char (*), ptr,
				entry, fixed bin (35)),
     transaction_manager_$user_shutdown entry (ptr, ptr, fixed bin (35))
     )				external;

/* External */

dcl  (
     dm_error_$system_not_initialized,
     error_table_$active_function,
     error_table_$too_many_args,
     error_table_$unimplemented_version
     )				fixed bin (35) external;

/* END OF DECLARATIONS */
%page;
/* dm_user_shutdown:			repeat for reader	*/
/*    proc ();						*/

SETUP_INVOCATION:
   do;
      call cu_$arg_list_ptr (arg_list_ptr);

      tm_shutdown_info_ptr = null ();
      on cleanup call CLEAN_UP ();

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

      on dm_not_available_
         call ERROR_RETURN (dm_error_$system_not_initialized);

      call ssu_$return_arg (sci_ptr, number_of_args, is_active_function,
	 (null ()), (0));				/* don't care what AF return info is */

      if is_active_function then
         call ERROR_RETURN (error_table_$active_function);
      if number_of_args > 0 then
         call ERROR_RETURN (error_table_$too_many_args, "^/Usage: ^a", myname);
   end SETUP_INVOCATION;

DO_PER_PROCESS_SHUTDOWN:
   do;
      call transaction_manager_$user_shutdown (get_dm_free_area_ (),
	 tm_shutdown_info_ptr, code);

      if code ^= 0 then
         call ERROR_RETURN (code, "^/Unable to do dm per-process shutdown.");
      else if tm_shutdown_info_ptr = null () then
         call RETURN ();				/* User wasn't using DM. */

      call CHECK_VERSION (tm_shutdown_info.version, TM_SHUTDOWN_INFO_VERSION_1,
	 "tm_shutdown_info");
   end DO_PER_PROCESS_SHUTDOWN;


/* Tell the user what tm_ did for him/her */
   if tm_shutdown_info.count > 0 then do;
      if tm_shutdown_info.count = 1 then
         call ioa_ ("A transaction was adjusted.");
      else call ioa_ ("^d transactions were adjusted.^/",
	      tm_shutdown_info.count);

      do shut_info_index = 1 to tm_shutdown_info.count;
         if tm_shutdown_info.txn_id (shut_info_index) ^= ""b then do;
	  call convert_status_code_ (tm_shutdown_info
	       .error_code (shut_info_index), "", err_msg);
	  call ioa_ (
	       "^5xTransaction id: ^d, Operation: ^a, State: ^d, ^[Error: ^a^;^]",
	       bin (tm_shutdown_info.txn_id (shut_info_index)),
	       OP_NAME (tm_shutdown_info.op_completed (shut_info_index)),
	       tm_shutdown_info.state (shut_info_index),
	       (tm_shutdown_info.error_code (shut_info_index) ^= 0), err_msg)
	       ;
         end;
      end;
   end;

   call RETURN ();
%page;
MAIN_RETURN:
   return;
%skip (4);
RETURN:
   proc ();
ABORT_ENTRY:
   entry ();					/* ABORT currently same as RETURN */

   call FINISH ();
   go to MAIN_RETURN;

   end RETURN;
%skip (4);
FINISH:
   proc ();
CLEAN_UP:
   entry ();					/* CLEAN_UP currently same as FINISH */

   call ssu_$destroy_invocation (sci_ptr);

   if ^finish_started_freeing_structures then
FREE_STRUCTURES:
      do;
      finish_started_freeing_structures = YES;
      if tm_shutdown_info_ptr ^= null () then
         free tm_shutdown_info;
   end FREE_STRUCTURES;

   return;

   end FINISH;
%skip (4);
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

dcl  cv_p_received_version		char (8) aligned;
dcl  cv_p_expected_version		char (8) aligned;
dcl  cv_p_structure_name		char (*);

   if cv_p_received_version ^= cv_p_expected_version then
      call ERROR_RETURN (error_table_$unimplemented_version,
	 "^/Expected version ^d of the ^a structure.^/Received version ^d, instead.",
	 cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
ERROR_RETURN_FROM_SSU_SETUP:
   proc (erfss_p_code);

dcl  erfss_p_code			fixed bin (35) parameter;

   call com_err_ (erfss_p_code, myname, SSU_INVOCATION_ERR_MSG);

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

   end ERROR_RETURN_FROM_SSU_SETUP;
%skip (4);
ERROR_RETURN:
   proc options (variable);

dcl  (
     er_arg_list_ptr		ptr,
     er_code			fixed bin (35),
     er_message			char (1024),
     er_message_length		fixed bin (21)
     )				automatic;

dcl  (
     er_fixed_bin_35_value		fixed bin (35),
     er_message_overlay		char (er_message_length)
     )				based;

   call cu_$arg_list_ptr (er_arg_list_ptr);
   er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_fixed_bin_35_value;

   if er_arg_list_ptr -> arg_list.arg_count > 1 then do;
      call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message,
	 er_message_length, IOA_GENERAL_RS_DONT_PAD,
	 IOA_GENERAL_RS_NO_NEW_LINE);
      call ssu_$abort_line (sci_ptr, er_code,
	 addr (er_message) -> er_message_overlay);
   end;
   else						/* no extra info */
        call ssu_$abort_line (sci_ptr, er_code);

   end ERROR_RETURN;
%page;
%include dm_tm_shutdown_info;
%page;
%include arg_list;

   end dm_user_shutdown;




		    dm_vector_util_.alm             03/06/85  0751.0re  03/05/85  0755.9       12339



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
	name	dm_vector_util_

" Modified:
" 11/10/83 by Matthew Pierret: Added $copy_vector and $copy_vector_list.
"             Added $free_vector and $free_vector_list.
" 11/20/84 by Lindsey Spratt: Taken from vector_util_.
" 12/05/84 by Lindsey Spratt: Fixed to reference dm_vu_* instead of vu_*.
" 12/20/84 by Lindsey Spratt: Removed the unreferenced
"	    $copy_typed_vector_array.
"
" Macro to generate a call to an external entrypoint in the utilities

	macro	ext_transfer
	segdef	&1
&1:	getlp
	tra	&2

	&end

	ext_transfer append_simple_typed_vector,dm_vu_append_simple_typed$dm_vu_append_simple_typed
	ext_transfer copy_typed_vector,dm_vu_copy_typed_vector$dm_vu_copy_typed_vector
	ext_transfer err_no_operation,dm_vu_err_no_operation$dm_vu_err_no_operation
	ext_transfer free_typed_vector,dm_vu_free_typed_vector$dm_vu_free_typed_vector
	ext_transfer free_typed_vector_array,dm_vu_free_tva$dm_vu_free_tva
	ext_transfer init_typed_vector_array,dm_vu_init_tva$dm_vu_init_tva
          ext_transfer merge_typed_vector_array,dm_vu_merge_tva$dm_vu_merge_tva
	end




		    dm_vu_append_simple_typed.pl1   11/17/86  0956.2rew 11/17/86  0954.4      163872



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



/****^  HISTORY COMMENTS:
  1) change(86-10-28,Dupuis), approve(86-11-13,MCR7573), audit(86-11-14,Blair),
     install(86-11-17,MR12.0-1220):
     Fixed a subsciptrange error in the ERROR_FINISH proc.
                                                   END HISTORY COMMENTS */


/* DESCRIPTION:

          This module appends a simple_typed_vector to a typed_vector_array.
     The TVA is extended if necessary.  When extended, the old TVA structure
     is freed and the p_tva_ptr parameter is changed to point to the new,
     extended, copy of the TVA.

     There are two calling sequences to this module:
     
     call dm_vu_append_simple_typed (area_ptr, slot_increase_factor,
     free_old_tva, value1, value2,..., valueN, typed_vector_array_ptr, code);
     
     or,

     call dm_vu_append_simple_typed (area_ptr, slot_increase_factor,
     free_old_tva, typed_vector_array_ptr, code);
     
     Also, this module can be invoked as a function with the same arguments,
     and it will return a pointer to the newly generated typed_vector.
     
     The first calling sequence will fill in the simple_typed_vector with
     pointers to copies of the supplied values.  The second calling sequence
     creates a simple_typed_vector with all null values.
     
*/

/* HISTORY:

Written by Lindsey Spratt, 03/01/82.

Modified:
05/17/82 by Lindsey Spratt: Fixed handling of varying strings.
09/24/82 by Lindsey Spratt:  Fixed bug where the simple_typed_vector_ptr was
	  not being recorded in the typed_vector_array if there were enough
	  slots in the tva to just add the vector.  It was working correctly
	  in the case where the tva had to be grown.
06/16/83 by Lindsey L. Spratt:  Fixed the problem where the parameter
            typed_vector_array_ptr was not being updated with the new value
            for the typed_vector_array_ptr when the typed_vector_array was
            grown.  Also, changed the handling of varying strings to assume
            that the storage pointed at by the arg_list ptr (for a varying
            string) is the length word and the string, instead of assuming
            that the "size" in the descriptor is the length and that the
            arg_list ptr points at just the string.
12/18/84 by Lindsey L. Spratt:  Changed to have standard format.  Changed to
            use modern sub_err_ calling sequence.  Changed to use
            error_table_$bad_subr_arg rather than $bad_arg.  Added check for
            enough args being supplied, which signals with $wrong_no_of_args
            if the check fails.  Changed to use the ERROR_RETURN technology
            for reporting errors.  Changed to reference data_format_util_
            rather than the obsolete data_mgmt_util_.
02/11/85 by Lindsey L. Spratt:  Changed to use the RETURN internal procedure.
            Added the ability to return the error_table_$area_too_small error
            code when an area condition occurs.
03/08/85 by Lindsey L. Spratt:  Fixed a bug due to old_tva_ptr being
            uninitialized.  Fixed to initialize all of the automatic ptr
            variables.
03/18/85 by Lindsey L. Spratt:  Cleaned up the implementation of the
            ERROR_RETURN proc.  Changed entire procedure to use only the
            cu_$*_rel entries.  Enhanced error reporting of GET_ARG_PTR to
	  include a name of the desired descriptor type.
*/


/* format: style2,ind3 */
dm_vu_append_simple_typed:
   proc () options (variable);

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

      dcl	    arg_idx	       fixed bin;
      dcl	    arg_length	       fixed bin (21) init (0);
      dcl	    arg_list_arg_count     fixed bin;
      dcl	    arg_list_ptr	       ptr init (null ());
      dcl	    arg_ptr	       ptr init (null);
      dcl	    code_arg_idx	       fixed bin;
      dcl	    dim_idx	       fixed bin;
      dcl	    free_old_typed_vector_array_ptr
			       ptr init (null ());
      dcl	    nargs		       fixed bin;
      dcl	    ndims		       fixed bin;
      dcl	    number_of_nonvalue_args_at_end
			       fixed bin;
      dcl	    number_of_values_given fixed bin (35) init (0);
      dcl	    old_tva_ptr	       ptr init (null ());
      dcl	    packed	       bit (1) aligned;
      dcl	    p_code_ptr	       ptr init (null ());
      dcl	    p_typed_vector_array_ptr_ptr
			       ptr init (null ());
      dcl	    scale		       fixed bin;
      dcl	    size		       fixed bin (17) aligned;
      dcl	    storage_size	       fixed bin (35);
      dcl	    storage_string_ptr     ptr init (null ());
      dcl	    values_given	       bit (1) aligned init ("0"b);
      dcl	    tv_ptr_arg_idx	       fixed bin;
      dcl	    tva_ptr_arg_idx	       fixed bin;
      dcl	    type		       fixed bin;
      dcl	    vector_idx	       fixed bin;
      dcl	    work_area_ptr	       ptr init (null ());

/* Based */

      dcl	    descriptor_string      bit (36) aligned based;
      dcl	    free_old_typed_vector_array
			       bit (1) aligned based (free_old_typed_vector_array_ptr);
      dcl	    p_typed_vector_array_ptr
			       based (p_typed_vector_array_ptr_ptr) ptr;
      dcl	    p_code	       based (p_code_ptr) fixed bin (35);
      dcl	    ptr_template	       based ptr aligned;
      dcl	    s_fixed_real_template  based fixed bin (35) aligned;
      dcl	    storage_string	       bit (storage_size) based (storage_string_ptr) aligned;
      dcl	    varying_bit_storage_string
			       bit (storage_size) varying based (storage_string_ptr);
      dcl	    varying_char_storage_string
			       char (storage_size) varying based (storage_string_ptr);
      dcl	    work_area	       area based (work_area_ptr);


/* Builtin */

      dcl	    (addr, addrel, null)
			       builtin;

/* Condition */

      dcl	    (area, cleanup)	       condition;

/* Constant */

      dcl	    (
	    AREA_IS_BIG_ENOUGH     init (0),
	    AREA_IS_TOO_SMALL      init (1)
	    )		       fixed bin (35) internal static options (constant);

      dcl	    (
	    BITS_PER_BYTE	       init (9),
	    BITS_PER_WORD	       init (36)
	    )		       fixed bin (35) internal static options (constant);
      dcl	    (NO_PAD, NO_NL)	       init ("0"b) bit (1) aligned internal static options (constant);

      dcl	    MYNAME	       init ("dm_vu_init_tva") char (40) varying internal static options (constant);

      dcl	    (
	    AREA_PTR_ARG_IDX       init (1),
	    SLOT_INCREASE_ARG_IDX  init (2),
	    FREE_OLD_TVA_ARG_IDX   init (3),
	    NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING
			       init (3),
	    TVA_PTR_ARG_OFFSET_FROM_SUBROUTINE_END
			       init (1),
	    TVA_PTR_ARG_OFFSET_FROM_FUNCTION_END
			       init (2),
	    CODE_ARG_OFFSET_FROM_SUBROUTINE_END
			       init (0),
	    CODE_ARG_OFFSET_FROM_FUNCTION_END
			       init (1),
	    NUMBER_OF_NONVALUE_ARGS_AT_SUBROUTINE_END
			       init (2),
	    NUMBER_OF_NONVALUE_ARGS_AT_FUNCTION_END
			       init (3),
	    NO_TYPE	       init (-1)
	    )		       fixed bin internal static options (constant);


/* Entry */

      dcl	    cu_$arg_count_rel      entry (fixed bin, ptr, fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    data_format_util_$get_data_bit_length
			       entry (bit (36) aligned, fixed bin (35), fixed bin (35));
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    dm_vector_util_$free_typed_vector
			       entry (ptr, ptr, ptr, fixed bin (35));
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    error_table_$area_too_small,
	    error_table_$bad_subr_arg,
	    error_table_$wrong_no_of_args
	    )		       fixed bin (35) ext;

/* END OF DECLARATIONS */

      call cu_$arg_list_ptr (arg_list_ptr);
      call cu_$arg_count_rel (nargs, arg_list_ptr, (0));
      arg_list_arg_count = nargs;

      call decode_descriptor_ (arg_list_ptr, nargs, type, packed, ndims, size, scale);
      if type = pointer_desc
      then
         do;
	  tv_ptr_arg_idx = nargs;
	  tva_ptr_arg_idx = nargs - TVA_PTR_ARG_OFFSET_FROM_FUNCTION_END;
	  code_arg_idx = nargs - CODE_ARG_OFFSET_FROM_FUNCTION_END;
	  number_of_nonvalue_args_at_end = NUMBER_OF_NONVALUE_ARGS_AT_FUNCTION_END;
         end;
      else
         do;
	  tv_ptr_arg_idx = -1;
	  ;
	  tva_ptr_arg_idx = nargs - TVA_PTR_ARG_OFFSET_FROM_SUBROUTINE_END;
	  code_arg_idx = nargs - CODE_ARG_OFFSET_FROM_SUBROUTINE_END;
	  number_of_nonvalue_args_at_end = NUMBER_OF_NONVALUE_ARGS_AT_SUBROUTINE_END;
         end;

      if (nargs > (NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + number_of_nonvalue_args_at_end))
      then values_given = "1"b;
      else if (nargs = (NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + number_of_nonvalue_args_at_end))
      then values_given = "0"b;
      else call sub_err_ (error_table_$wrong_no_of_args, MYNAME, ACTION_CANT_RESTART, null (), 0,
	      "^/This program expects ^d arguments, or more, but was called with ^d arguments.",
	      (NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + number_of_nonvalue_args_at_end), nargs);

      on cleanup call ERROR_FINISH ();

      p_code_ptr = GET_ARG_PTR (arg_list_ptr, code_arg_idx, s_fixed_real_desc, "short_fixed_real");

      work_area_ptr = GET_ARG_PTR (arg_list_ptr, AREA_PTR_ARG_IDX, pointer_desc, "pointer") -> ptr_template;

      p_typed_vector_array_ptr_ptr = GET_ARG_PTR (arg_list_ptr, tva_ptr_arg_idx, pointer_desc, "pointer");

      typed_vector_array_ptr = p_typed_vector_array_ptr;

      tva_number_of_vector_slots =
	 typed_vector_array.number_of_vector_slots
	 + GET_ARG_PTR (arg_list_ptr, SLOT_INCREASE_ARG_IDX, s_fixed_real_desc, "short_fixed_real")
	 -> s_fixed_real_template;

      free_old_typed_vector_array_ptr = GET_ARG_PTR (arg_list_ptr, FREE_OLD_TVA_ARG_IDX, bit_desc, "nonvarying bit");

      stv_number_of_dimensions = typed_vector_array.number_of_dimensions;

      on area call RETURN (AREA_IS_TOO_SMALL);

      alloc simple_typed_vector in (work_area);
      simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
      simple_typed_vector.dimension (*).value_ptr = null ();

      if values_given
      then
         do;
	  number_of_values_given = nargs - (number_of_nonvalue_args_at_end + NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING);

	  do arg_idx = NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING + 1 to nargs - number_of_nonvalue_args_at_end;

	     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_length, p_code, arg_list_ptr);
	     if p_code ^= 0
	     then call ERROR_RETURN (p_code, "^/Unable to get a pointer to parameter ^d.", arg_idx);

	     call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);

	     if type = v_char_desc
	     then storage_size = size * BITS_PER_BYTE + BITS_PER_WORD;
	     else if type = v_bit_desc
	     then storage_size = size + BITS_PER_WORD;
	     else
	        do;
		 call data_format_util_$get_data_bit_length (arg_list_ptr -> arg_list.desc_ptrs (arg_idx)
		      -> descriptor_string, storage_size, p_code);
		 if p_code ^= 0
		 then call ERROR_RETURN (p_code, "^/Unable to get the length (in bits) of parameter ^d.", arg_idx);
	        end;

	     alloc storage_string in (work_area);
	     if type = v_char_desc
	     then varying_char_storage_string = addrel (arg_ptr, -1) -> varying_char_storage_string;
	     else if type = v_bit_desc
	     then varying_bit_storage_string = addrel (arg_ptr, -1) -> varying_bit_storage_string;
	     else storage_string = arg_ptr -> storage_string;

	     simple_typed_vector.dimension (arg_idx - NUMBER_OF_NONVALUE_ARGS_AT_BEGINNING).value_ptr =
		storage_string_ptr;

	  end;
         end;

      else number_of_values_given = 0;

      do dim_idx = number_of_values_given + 1 to simple_typed_vector.number_of_dimensions;
         simple_typed_vector.dimension (dim_idx).value_ptr = null;
      end;


      if typed_vector_array.number_of_vectors + 1 > typed_vector_array.number_of_vector_slots
      then
         do;
	  tva_maximum_dimension_name_length = typed_vector_array.maximum_dimension_name_length;
	  tva_number_of_dimensions = typed_vector_array.number_of_dimensions;
	  old_tva_ptr = typed_vector_array_ptr;
	  alloc typed_vector_array in (work_area);
	  typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;
	  typed_vector_array.dimension_table = old_tva_ptr -> typed_vector_array.dimension_table;
	  typed_vector_array.number_of_vectors = old_tva_ptr -> typed_vector_array.number_of_vectors;
	  do vector_idx = 1 to typed_vector_array.number_of_vectors;
	     typed_vector_array.vector_slot (vector_idx) = old_tva_ptr -> typed_vector_array.vector_slot (vector_idx);
	  end;
	  p_typed_vector_array_ptr = typed_vector_array_ptr;
         end;

      typed_vector_array.number_of_vectors = typed_vector_array.number_of_vectors + 1;
      typed_vector_array.vector_slot (typed_vector_array.number_of_vectors) = simple_typed_vector_ptr;


      if tv_ptr_arg_idx > 0
      then GET_ARG_PTR (arg_list_ptr, tv_ptr_arg_idx, pointer_desc, "pointer") -> ptr_template = simple_typed_vector_ptr;

      call RETURN (AREA_IS_BIG_ENOUGH);

MAIN_RETURN:
      return;


RETURN:
   proc (r_p_area_status);
      dcl	    r_p_area_status	       fixed bin (35) parm;
      if r_p_area_status = AREA_IS_BIG_ENOUGH
      then
         do;
	  p_code = 0;
	  call FINISH ();
         end;
      else if r_p_area_status = AREA_IS_TOO_SMALL
      then
         do;
	  p_code = error_table_$area_too_small;
	  call ERROR_FINISH ();
         end;
      else call ERROR_RETURN (error_table_$bad_subr_arg, "^/There is an internal program logic error in this program.
The RETURN internal procedure was given an area status of ^d, 
when only ^d and ^d are defined statuses.", r_p_area_status, AREA_IS_BIG_ENOUGH, AREA_IS_TOO_SMALL);
      goto MAIN_RETURN;
   end RETURN;


ERROR_RETURN:
   proc () options (variable);
      dcl	    er_p_code_ptr	       ptr init (null ());
      dcl	    er_p_code	       based (er_p_code_ptr) fixed bin (35);
      dcl	    er_arg_list_ptr	       ptr init (null);
      dcl	    er_code	       fixed bin (35);
      dcl	    er_msg	       char (1024);
      dcl	    er_based_msg	       char (er_msg_length) based (addr (er_msg));
      dcl	    er_msg_length	       fixed bin (21) init (0);

      dcl	    er_nargs	       fixed bin;
      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_count_rel (er_nargs, er_arg_list_ptr, (0));
      if er_nargs = 0
      then er_code = 0;
      else
         do;
	  call cu_$arg_ptr_rel (1, er_p_code_ptr, (0), (0), er_arg_list_ptr);
	  er_code = er_p_code;
         end;
      if er_nargs >= 2
      then call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_msg, er_msg_length, NO_PAD, NO_NL);

      call sub_err_ (er_code, MYNAME, ACTION_CANT_RESTART, null (), 0, "^a", er_based_msg);

   end ERROR_RETURN;
%page;
FINISH:
   proc ();
      if free_old_typed_vector_array_ptr ^= null
      then if free_old_typed_vector_array & old_tva_ptr ^= null
	 then free old_tva_ptr -> typed_vector_array;
   end FINISH;

ERROR_FINISH:
   proc ();
      if p_typed_vector_array_ptr_ptr ^= null
      then
         do;
	  if old_tva_ptr ^= null
	  then
	     do;
	        p_typed_vector_array_ptr = old_tva_ptr;
	        old_tva_ptr = null;
	        if p_typed_vector_array_ptr ^= typed_vector_array_ptr & typed_vector_array_ptr ^= null
	        then free typed_vector_array;
	     end;
	  if simple_typed_vector_ptr ^= null
	  then
	     do;

	        call dm_vector_util_$free_typed_vector (work_area_ptr, p_typed_vector_array_ptr,
		   simple_typed_vector_ptr, (0));
	        if p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors > 0
	        then if p_typed_vector_array_ptr
		        -> typed_vector_array
		        .vector_slot (p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors)
		        = simple_typed_vector_ptr
		   then p_typed_vector_array_ptr
			   -> typed_vector_array
			   .vector_slot (p_typed_vector_array_ptr -> typed_vector_array.number_of_vectors) = null;
	     end;
         end;
   end ERROR_FINISH;
%page;
GET_ARG_PTR:
   proc (gap_p_arg_list_ptr, gap_p_arg_idx, gap_p_required_type, gap_p_type_name) returns (ptr);
      dcl	    gap_p_arg_list_ptr     ptr parm;
      dcl	    gap_p_arg_idx	       fixed bin parm;
      dcl	    gap_p_required_type    fixed bin parm;
      dcl	    gap_p_type_name	       char (*) parm;

      dcl	    gap_arg_ptr	       ptr init (null);
      dcl	    gap_arg_len	       fixed bin (21);
      dcl	    gap_code	       fixed bin (35) init (0);
      dcl	    gap_ndims	       fixed bin;
      dcl	    gap_packed	       bit (1) aligned;
      dcl	    gap_scale	       fixed bin;
      dcl	    gap_size	       fixed bin;
      dcl	    gap_type	       fixed bin;

      if gap_p_required_type ^= NO_TYPE
      then
         do;
	  call decode_descriptor_ (gap_p_arg_list_ptr, gap_p_arg_idx, gap_type, gap_packed, gap_ndims, gap_size,
	       gap_scale);
	  if gap_type ^= gap_p_required_type
	  then call ERROR_RETURN (error_table_$bad_subr_arg,
		  "^/Parameter ^d must be of type ^d (^a), but the one given was ^d.", gap_p_arg_idx,
		  gap_p_required_type, gap_p_type_name, gap_type);
         end;

      call cu_$arg_ptr_rel (gap_p_arg_idx, gap_arg_ptr, gap_arg_len, gap_code, gap_p_arg_list_ptr);
      if gap_code ^= 0
      then call ERROR_RETURN (gap_code, "^/Unable to get a pointer to parameter ^d.", gap_p_arg_idx);

      return (gap_arg_ptr);
   end GET_ARG_PTR;
%page;
%include vu_typed_vector_array;
%page;
%include vu_typed_vector;
%page;
%include desc_types;
%page;
%include sub_err_flags;
%page;
%include arg_list;
   end dm_vu_append_simple_typed;




		    dm_vu_copy_typed_vector.pl1     10/24/88  1638.8r w 10/24/88  1400.1       53091



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* DESCRIPTION:
         This subroutine takes a typed_vector and a pointer to its associated
     typed_vector_array,  and a pointer to an area in which to put the output,
     and creates a new typed_vector in the output area.  The  pointer  to  the
     new typed_vector is returned.
*/

/* HISTORY:
Written by Lindsey L. Spratt, 02/07/83.
Modified:
12/18/84 by Lindsey L. Spratt:  Fixed to reference data_format_util_ instead
            of the obsolete data_mgmt_util_.  Changed to have a cleanup
            handler and be prepared to free the simple typed vector on
            cleanup.  Moved the proc stmt.  Declared the unspec builtin.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */
dm_vu_copy_typed_vector:
   proc (p_caller_area_ptr, p_typed_vector_array_ptr, p_original_typed_vector_ptr, p_copy_typed_vector_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_caller_area_ptr      ptr parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_original_typed_vector_ptr
			       ptr parameter;
      dcl	    p_copy_typed_vector_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    caller_area_ptr	       ptr init (null);
      dcl	    dim_idx	       fixed bin (35) init (0);
      dcl	    value_string_size      fixed bin (35) init (0);
      dcl	    value_string_ptr       ptr init (null);
      dcl	    original_value_ptr     ptr init (null);

/* Based */

      dcl	    caller_area	       area based (caller_area_ptr);
      dcl	    based_real_fix_bin_1u  fixed bin (35) unaligned based;
      dcl	    value_string	       bit (value_string_size) based (value_string_ptr) aligned;

/* Builtin */

      dcl	    (null, unspec)	       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dm_vu_copy_typed_vector") char (32) varying internal static
			       options (constant);
      dcl	    (
	    BITS_PER_BYTE	       init (9),
	    BITS_PER_WORD	       init (36)
	    )		       int static options (constant) fixed bin (17);

/* Entry */

      dcl	    data_format_util_$get_data_bit_length
			       entry (bit (36) aligned, fixed bin (35), fixed bin (35));
      dcl	    dm_vector_util_$free_typed_vector
			       entry (ptr, ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      caller_area_ptr = p_caller_area_ptr;
      p_code = 0;
      p_copy_typed_vector_ptr = null;
      call CHECK_VERSION ((p_original_typed_vector_ptr -> simple_typed_vector.type), (SIMPLE_TYPED_VECTOR_TYPE),
	 "simple_typed_vector");

      typed_vector_array_ptr = p_typed_vector_array_ptr;
      call CHECK_VERSION (typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");

      simple_typed_vector_ptr = null;
      on cleanup call ERROR_FINISH ();

      stv_number_of_dimensions = p_original_typed_vector_ptr -> simple_typed_vector.number_of_dimensions;
      alloc simple_typed_vector in (caller_area);
      simple_typed_vector.type = SIMPLE_TYPED_VECTOR_TYPE;
DIMENSION_LOOP:
      do dim_idx = 1 to simple_typed_vector.number_of_dimensions;
         arg_descriptor_ptr = typed_vector_array.dimension_table (dim_idx).descriptor_ptr;
         original_value_ptr = p_original_typed_vector_ptr -> simple_typed_vector.dimension (dim_idx).value_ptr;
         if arg_descriptor.type = varying_char_dtype
         then value_string_size = original_value_ptr -> based_real_fix_bin_1u * BITS_PER_BYTE + BITS_PER_WORD;
         else if arg_descriptor.type = varying_bit_dtype
         then value_string_size = original_value_ptr -> based_real_fix_bin_1u + BITS_PER_WORD;
         else
	  do;
	     call data_format_util_$get_data_bit_length (unspec (arg_descriptor), value_string_size, p_code);
	     if p_code ^= 0
	     then call ERROR_RETURN (p_code);
	  end;
         alloc value_string in (caller_area);
         value_string = original_value_ptr -> value_string;
         simple_typed_vector.dimension (dim_idx).value_ptr = value_string_ptr;

      end DIMENSION_LOOP;

      p_copy_typed_vector_ptr = simple_typed_vector_ptr;

MAIN_RETURN:
      return;


ERROR_FINISH:
   proc ();
      if simple_typed_vector_ptr ^= null & p_copy_typed_vector_ptr ^= simple_typed_vector_ptr
      then call dm_vector_util_$free_typed_vector (caller_area_ptr, typed_vector_array_ptr, simple_typed_vector_ptr, (0));
   end ERROR_FINISH;

ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parm;
      call ERROR_FINISH ();
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);
      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);
   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include std_descriptor_types;
%page;
%include vu_typed_vector;
%page;
%include vu_typed_vector_array;
%page;
%include arg_descriptor;
   end dm_vu_copy_typed_vector;




		    dm_vu_err_no_operation.pl1      01/04/85  0952.6re  01/03/85  1151.5        7254



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
dm_vu_err_no_operation:
   proc (p1_ptr, p2_fb17, p3_fb17, p4_ptr, p5_ptr, p_code);
      dcl	    p1_ptr	       ptr;
      dcl	    p2_fb17	       fixed bin (17);
      dcl	    p3_fb17	       fixed bin (17);
      dcl	    p4_ptr	       ptr;
      dcl	    p5_ptr	       ptr;
      dcl	    p_code	       fixed bin (35);

      dcl	    error_table_$no_operation
			       ext fixed bin (35);

      p_code = error_table_$no_operation;
   end dm_vu_err_no_operation;




		    dm_vu_free_tva.pl1              03/06/85  0751.0re  03/05/85  0756.0       34524



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: style2,ind3 */
dm_vu_free_tva:
   proc (p_work_area_ptr, p_typed_vector_array_ptr, p_code);

/* DESCRIPTION:

         This  module frees the storage associated with a typed_vector_array.
     It invokes dm_vu_$free_typed_vector to free the storage associated with  the
     individual typed_vectors.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 09/24/82.
Modified:
06/08/83 by Matthew Pierret:  Changed typed_vector loop to terminate at
            min (tva.number_of_vector_slots, tva.number_of_vectors).
            Previously it terminated at tva.number_of_vectors, and there
            was a case in which the array was a 0-extent array but
            tva.number_of_vectors was not equal to 0.
12/05/84 by Lindsey L. Spratt:  Declared dm_vector_util_$free_typed_vector.
01/10/85 by Lindsey L. Spratt:  Changed check_version to CHECK_VERSION, and
            add cv_ prefixes to its variables.  Fixed sub_err_ call to use
            ACTION_CANT_RESTART instead of "s".
01/23/85 by Lindsey L. Spratt:  dcled the min builtin.
*/

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    work_area_ptr	       ptr;

      dcl	    (vector_idx, dim_idx)  fixed bin;

/* Based */

      dcl	    based_bit_36_aligned   bit (36) aligned based;
      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (min, null)	       builtin;

/* Constant */

      dcl	    myname	       init ("dm_vu_free_tva") char (32) varying internal static options (constant);

/* Entry */

      dcl	    dm_vector_util_$free_typed_vector
			       entry (ptr, ptr, ptr, fixed bin (35));
      dcl	    sub_err_	       entry options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;

/* END OF DECLARATIONS */

      work_area_ptr = p_work_area_ptr;
      typed_vector_array_ptr = p_typed_vector_array_ptr;
      p_code = 0;

      call CHECK_VERSION (typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");

      do vector_idx = 1 to min (typed_vector_array.number_of_vector_slots, typed_vector_array.number_of_vectors);
         call dm_vector_util_$free_typed_vector (p_work_area_ptr, typed_vector_array_ptr,
	    typed_vector_array.vector_slot (vector_idx), p_code);
         if p_code ^= 0
         then return;
      end;

      do dim_idx = 1 to typed_vector_array.number_of_dimensions;
         free typed_vector_array.dimension_table (dim_idx).descriptor_ptr -> based_bit_36_aligned in (work_area);
      end;

      free typed_vector_array in (work_area);
      p_typed_vector_array_ptr = null;

      return;
%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include vu_typed_vector_array;
%page;
%include vu_entry_dcls;
%page;
%include sub_err_flags;
   end dm_vu_free_tva;




		    dm_vu_free_typed_vector.pl1     10/24/88  1638.8r w 10/24/88  1400.1       46638



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* DESCRIPTION:

         This  module frees the storage associated with a typed_vector.  This
     includes determining the amount of storage used in the value  storage  as
     indicated by the descriptor in the typed_vector_array.
*/

/* HISTORY:

Written by Lindsey L. Spratt, 09/24/82.
Modified:
12/18/84 by Lindsey L. Spratt:  Moved the proc stmt to standard location.
            Changed to use the modern sub_err_flags.  Changed to use
            data_format_util_ instead of data_mgmt_util_.  Uppercased the name
            of the internal proc CHECK_VERSION.  Added the cv_ prefix to the
            CHECK_VERSION proc's variable names.
12/19/84 by Lindsey L. Spratt:  Fixed to ignore null value_ptr's.  Fixed to
            check the return code from the dfu_$get_data_bit_length call.
            Added the ERROR_RETURN proc.  Changed storage_string to be
            explicitly based on storage_string_ptr.
*/

/* format: style2,ind3 */
dm_vu_free_typed_vector:
   proc (p_work_area_ptr, p_typed_vector_array_ptr, p_typed_vector_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_work_area_ptr	       ptr parameter;
      dcl	    p_typed_vector_array_ptr
			       ptr parameter;
      dcl	    p_typed_vector_ptr     ptr parameter;
      dcl	    p_code	       fixed bin (35) parameter;

/* Automatic */

      dcl	    dim_idx	       fixed bin;
      dcl	    storage_size	       fixed bin (35);
      dcl	    storage_string_ptr     ptr init (null);
      dcl	    work_area_ptr	       ptr init (null);

/* Based */

      dcl	    descriptor_string      bit (36) aligned based;
      dcl	    storage_string	       bit (storage_size) aligned based (storage_string_ptr);
      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    myname	       init ("dm_vu_free_typed_vector") char (32) varying options (constant) internal
			       static;

      dcl	    (
	    BITS_PER_BYTE	       init (9),
	    BITS_PER_WORD	       init (36)
	    )		       fixed bin internal static options (constant);

/* Entry */

      dcl	    data_format_util_$get_data_bit_length
			       entry (bit (36) aligned, fixed bin (35), fixed bin (35));

      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    error_table_$unimplemented_version
			       fixed bin (35);

/* END OF DECLARATIONS */

      work_area_ptr = p_work_area_ptr;
      p_code = 0;
      typed_vector_array_ptr = p_typed_vector_array_ptr;
      call CHECK_VERSION (typed_vector_array.version, TYPED_VECTOR_ARRAY_VERSION_2, "typed_vector_array");

      simple_typed_vector_ptr = p_typed_vector_ptr;
      if simple_typed_vector.type ^= SIMPLE_TYPED_VECTOR_TYPE
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/This module only works on simple typed vectors, type ^d.  A type 
of ^d was provided.", SIMPLE_TYPED_VECTOR_TYPE, simple_typed_vector.type);

      do dim_idx = 1 to simple_typed_vector.number_of_dimensions;
         arg_descriptor_ptr = typed_vector_array.dimension_table (dim_idx).descriptor_ptr;
         if arg_descriptor.type = varying_char_dtype
         then storage_size = arg_descriptor.size * BITS_PER_BYTE + BITS_PER_WORD;
         else if arg_descriptor.type = varying_bit_dtype
         then storage_size = arg_descriptor.size + BITS_PER_WORD;
         else
	  do;
	     call data_format_util_$get_data_bit_length (arg_descriptor_ptr -> descriptor_string, storage_size, p_code);
	     if p_code ^= 0
	     then call ERROR_RETURN (p_code);
	  end;

         storage_string_ptr = simple_typed_vector.dimension (dim_idx).value_ptr;
         if storage_string_ptr ^= null
         then free storage_string in (work_area);
      end;

      free simple_typed_vector in (work_area);
      p_typed_vector_ptr = null;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parm;
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;


CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);
      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include arg_descriptor;
%page;
%include std_descriptor_types;
%page;
%include vu_typed_vector_array;
%page;
%include vu_typed_vector;
   end dm_vu_free_typed_vector;




		    dm_vu_init_tva.pl1              03/06/85  0751.0re  03/05/85  0756.0      126297



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

/* DESCRIPTION:
          This subroutine builds an "empty" typed_vector_array.  It has two
     calling sequences:

     call dm_vector_util_$init_tva (area_ptr, number_of_slots,
     number_of_dimensions, maximum_dimension_name_length,
     typed_vector_array_ptr, code);
     
     or,
     
     call dm_vector_util_$init_tva (area_ptr, number_of_slots,
     dim_1_name, dim_1_variable,...dim_N_name, dim_N_variable,
     typed_vector_array_ptr, code);
     
     The effective difference in the two calling sequences is whether or not
     the dimension_table has the name and descriptor_ptr variables filled in.
     In the first case, they are not filled in (they are initialized to "" and
     null) and the caller is left with this responsibility.  In the second
     case, they are filled in.  The descriptor for dimension I is the same as
     the descriptor for dim_I_variable.  The name for dimension I is the
     contents of the dim_I_name variable.

*/

/* HISTORY:

Written by Lindsey Spratt, 02/01/82.

Modified:
03/09/82 by Lindsey Spratt:  Changed to use named constants for the position
	  of the arguments.  Added another calling sequence.
06/28/82 by Lindsey Spratt: Changed from version 1 to version 2 of
            typed_vector_array.
06/17/83 by Lindsey L. Spratt:  Fixed to handle varying character strings as
            input parameters correctly.
12/18/84 by Lindsey L. Spratt:  Changed to use the ERROR_RETURN technology.
            Moved the proc stmt to the standard place.  Fixed to free the tva
            on cleanup.  Changed some uppercase automatic variables to
            lowercase.  Modernized the sub_err_ calls.  Added additional
            validity checks on the parameter list.
12/19/84 by Lindsey L. Spratt:  Added GET_ARG_PTR function.
*/
/* format: style2,ind3 */
%page;
/* format: style2,ind3 */
dm_vu_init_tva:
   proc () options (variable);

/* START OF DECLARATIONS */
/* Parameter */
/* Automatic */

      dcl	    arg_idx	       fixed bin;
      dcl	    arg_len	       fixed bin (21);
      dcl	    arg_list_arg_count     fixed bin;
      dcl	    arg_list_ptr	       ptr;
      dcl	    arg_ptr	       ptr init (null);
      dcl	    code		       fixed bin (35) init (0);
      dcl	    code_arg_idx	       fixed bin;
      dcl	    descriptor_string_ptr  ptr;
      dcl	    dim_idx	       fixed bin;
      dcl	    is_dimension_value     bit (1) aligned;
      dcl	    names_given	       bit (1) aligned init ("0"b);
      dcl	    nargs		       fixed bin;
      dcl	    ndims		       fixed bin;
      dcl	    number_of_name_args    fixed bin init (0);
      dcl	    p_code_ptr	       ptr;
      dcl	    p_typed_vector_array_ptr_ptr
			       ptr init (null);
      dcl	    packed	       bit (1) aligned;
      dcl	    scale		       fixed bin;
      dcl	    size		       fixed bin;
      dcl	    tva_ptr_arg_idx	       fixed bin;
      dcl	    type		       fixed bin;
      dcl	    work_area_ptr	       ptr;

/* Based */

      dcl	    char_template	       based char (size);
      dcl	    descriptor_string      bit (36) aligned based (descriptor_string_ptr);
      dcl	    p_code	       based (p_code_ptr) fixed bin (35);
      dcl	    p_typed_vector_array_ptr
			       based (p_typed_vector_array_ptr_ptr) ptr;
      dcl	    ptr_template	       based ptr;
      dcl	    s_fixed_real_template  based fixed bin;
      dcl	    v_char_template	       based char (size) varying;
      dcl	    work_area	       area based (work_area_ptr);

/* Builtin */

      dcl	    (addrel, length, max, null, rtrim)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    MYNAME	       init ("dm_vu_init_tva") char (40) varying internal static options (constant);
      dcl	    (
	    AREA_PTR_ARG_IDX       init (1),
	    NUMBER_OF_SLOTS_ARG_IDX
			       init (2),
	    NUMBER_OF_NONNAME_ARGS_AT_BEGINNING
			       init (2),
	    TVA_PTR_ARG_OFFSET_FROM_END
			       init (1),
	    NUMBER_OF_NONNAME_ARGS_AT_END
			       init (2),
	    NUMBER_OF_DIMENSIONS_ARG_IDX
			       init (3),
	    MAX_DIM_NAME_LEN_ARG_IDX
			       init (4),
	    NO_TYPE	       init (-1)
	    )		       fixed bin (17) internal static options (constant);
      dcl	    (NO_PAD, NO_NL)	       init ("0"b) bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    cu_$arg_count	       entry (fixed bin, fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr_rel	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
      dcl	    decode_descriptor_     entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
      dcl	    dm_vector_util_$err_no_operation
			       entry (ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
      dcl	    dm_vector_util_$free_typed_vector_array
			       entry (ptr, ptr, fixed bin (35));
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    sub_err_	       entry () options (variable);

/* External */

      dcl	    (
	    error_table_$bad_subr_arg,
	    error_table_$badcall,
	    error_table_$wrong_no_of_args
	    )		       fixed bin (35) ext;


/* END OF DECLARATIONS */

      typed_vector_array_ptr = null;

      on cleanup call ERROR_FINISH ();

      call cu_$arg_count (nargs, (0));
      arg_list_arg_count = nargs;
      call cu_$arg_list_ptr (arg_list_ptr);

      number_of_name_args = nargs - (NUMBER_OF_NONNAME_ARGS_AT_END + NUMBER_OF_NONNAME_ARGS_AT_BEGINNING);
      if number_of_name_args < 0
      then call sub_err_ (error_table_$wrong_no_of_args, MYNAME, ACTION_CANT_RESTART, null (), 0,
	      "^/This program requires at least ^d arguments in its calling sequence^/and it was called with only ^d.",
	      NUMBER_OF_NONNAME_ARGS_AT_END + NUMBER_OF_NONNAME_ARGS_AT_BEGINNING, nargs);

      code_arg_idx = nargs;
      tva_ptr_arg_idx = nargs - TVA_PTR_ARG_OFFSET_FROM_END;

      p_code_ptr = GET_ARG_PTR (arg_list_ptr, code_arg_idx, s_fixed_real_desc);

      p_code = 0;

      work_area_ptr = GET_ARG_PTR (arg_list_ptr, AREA_PTR_ARG_IDX, pointer_desc) -> ptr_template;

      tva_number_of_vector_slots =
	 GET_ARG_PTR (arg_list_ptr, NUMBER_OF_SLOTS_ARG_IDX, s_fixed_real_desc) -> s_fixed_real_template;

      p_typed_vector_array_ptr_ptr = GET_ARG_PTR (arg_list_ptr, tva_ptr_arg_idx, pointer_desc);

      call decode_descriptor_ (arg_list_ptr, NUMBER_OF_DIMENSIONS_ARG_IDX, type, packed, ndims, size, scale);
      if type = s_fixed_real_desc
      then
         do;
	  tva_number_of_dimensions =
	       GET_ARG_PTR (arg_list_ptr, NUMBER_OF_DIMENSIONS_ARG_IDX, NO_TYPE) -> s_fixed_real_template;
	  names_given = "0"b;

	  if nargs ^= NUMBER_OF_NONNAME_ARGS_AT_END + NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 2
	  then call sub_err_ (error_table_$wrong_no_of_args, MYNAME, ACTION_CANT_RESTART, null (), 0,
		  "^/This program was apparently called with the calling sequence providing
just the number of dimensions desired, rather than the names and data types
of the dimensions.  However, this calling sequence requires exactly ^d 
arguments and ^d were supplied.", NUMBER_OF_NONNAME_ARGS_AT_END + NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 2, nargs);

	  tva_maximum_dimension_name_length =
	       GET_ARG_PTR (arg_list_ptr, MAX_DIM_NAME_LEN_ARG_IDX, s_fixed_real_desc) -> s_fixed_real_template;
         end;
      else
         do;
	  names_given = "1"b;
	  if mod (number_of_name_args, 2) ^= 0
	  then call sub_err_ (error_table_$wrong_no_of_args, MYNAME, ACTION_CANT_RESTART, null (), 0,
		  "^/This program was apparently called with the calling sequence providing
the names and data types of the desired dimensions, rather than just the 
number of the dimensions." || "  However, this calling sequence requires two 
arguments per dimension, and an odd number of dimension definition 
arguments, ^d, was supplied.", number_of_name_args);

	  tva_number_of_dimensions = number_of_name_args / 2;

	  tva_maximum_dimension_name_length = 0;
	  do arg_idx = NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONNAME_ARGS_AT_END by 2;
	     call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);
	     call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
	     if code ^= 0
	     then call ERROR_RETURN (code, "^/Unable to get a pointer to parameter ^d.", arg_idx);


	     if type = char_desc
	     then tva_maximum_dimension_name_length =
		     max (tva_maximum_dimension_name_length, length (rtrim (arg_ptr -> char_template)));
	     else if type = v_char_desc
	     then tva_maximum_dimension_name_length =
		     max (tva_maximum_dimension_name_length, length (rtrim (addrel (arg_ptr, -1) -> v_char_template)))
		     ;
	     else call ERROR_RETURN (error_table_$bad_subr_arg,
		     "^/Parameter ^d must be the name of a dimension, a variable having
data type ^d or ^d, but has data type ^d.", arg_idx, char_desc, v_char_desc, type);

	  end;
         end;


      alloc typed_vector_array in (work_area);
      typed_vector_array.version = TYPED_VECTOR_ARRAY_VERSION_2;
      typed_vector_array.number_of_vectors = 0;
      typed_vector_array.dimension_table (*).descriptor_ptr = null;
      typed_vector_array.dimension_table (*).cv_to_print = dm_vector_util_$err_no_operation;
      typed_vector_array.dimension_table (*).cv_to_typed = dm_vector_util_$err_no_operation;

      is_dimension_value = "1"b;
      dim_idx = 0;

      if names_given
      then
         do arg_idx = NUMBER_OF_NONNAME_ARGS_AT_BEGINNING + 1 to nargs - NUMBER_OF_NONNAME_ARGS_AT_END;
	  is_dimension_value = ^is_dimension_value;
	  call decode_descriptor_ (arg_list_ptr, arg_idx, type, packed, ndims, size, scale);
	  call cu_$arg_ptr_rel (arg_idx, arg_ptr, arg_len, code, arg_list_ptr);
	  if code ^= 0
	  then call ERROR_RETURN (code, "^/Unable to get a pointer to parameter ^d.", arg_idx);

	  if is_dimension_value
	  then
	     do;
	        alloc descriptor_string in (work_area);
	        descriptor_string = arg_list_ptr -> arg_list.desc_ptrs (arg_idx) -> descriptor_string;
	        typed_vector_array.dimension_table (dim_idx).descriptor_ptr = descriptor_string_ptr;
	     end;

	  else if type = char_desc
	  then
	     do;
	        dim_idx = dim_idx + 1;
	        typed_vector_array.dimension_table (dim_idx).name = rtrim (arg_ptr -> char_template);
	     end;
	  else if type = v_char_desc
	  then
	     do;
	        dim_idx = dim_idx + 1;
	        typed_vector_array.dimension_table (dim_idx).name = rtrim (addrel (arg_ptr, -1) -> v_char_template);
	     end;
	  else call ERROR_RETURN (error_table_$bad_subr_arg,
		  "^/Parameter ^d must be the name of a dimension, a variable having
data type ^d or ^d, but has data type ^d.", arg_idx, char_desc, v_char_desc, type);

         end;
      else typed_vector_array.dimension_table.name = "";

      p_typed_vector_array_ptr = typed_vector_array_ptr;
MAIN_RETURN:
      return;



ERROR_RETURN:
   proc () options (variable);
      dcl	    er_arg_list_ptr	       ptr init (null);
      dcl	    er_code	       fixed bin (35);
      dcl	    er_msg	       varying based (addr (er_msg_struc)) char (length (er_msg_struc.str));
      dcl	    1 er_msg_struc,
	      2 len	       fixed bin (21) aligned,
	      2 str	       char (1024) unaligned;
      dcl	    er_nargs	       fixed bin;
      dcl	    er_s_fixed_real_template
			       based fixed bin (35);
      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_count (er_nargs, (0));
      if er_nargs = 0
      then er_code = 0;
      else er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_s_fixed_real_template;
      if er_nargs < 2
      then er_msg = "";
      else call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_msg_struc.str, er_msg_struc.len, NO_PAD, NO_NL);

      call sub_err_ (er_code, MYNAME, ACTION_CANT_RESTART, null (), 0, er_msg);

   end ERROR_RETURN;
%page;
ERROR_FINISH:
   proc ();
      if typed_vector_array_ptr ^= null
      then if p_typed_vector_array_ptr ^= typed_vector_array_ptr
	 then call dm_vector_util_$free_typed_vector_array (work_area_ptr, typed_vector_array_ptr, (0));
   end ERROR_FINISH;
%page;
GET_ARG_PTR:
   proc (gap_p_arg_list_ptr, gap_p_arg_idx, gap_p_required_type) returns (ptr);
      dcl	    gap_p_arg_list_ptr     ptr parm;
      dcl	    gap_p_arg_idx	       fixed bin parm;
      dcl	    gap_p_required_type    fixed bin parm;

      dcl	    gap_arg_ptr	       ptr init (null);
      dcl	    gap_arg_len	       fixed bin (21);
      dcl	    gap_code	       fixed bin (35) init (0);
      dcl	    gap_ndims	       fixed bin;
      dcl	    gap_packed	       bit (1) aligned;
      dcl	    gap_scale	       fixed bin;
      dcl	    gap_size	       fixed bin;
      dcl	    gap_type	       fixed bin;

      if gap_p_required_type ^= NO_TYPE
      then
         do;
	  call decode_descriptor_ (gap_p_arg_list_ptr, gap_p_arg_idx, gap_type, gap_packed, gap_ndims, gap_size,
	       gap_scale);
	  if gap_type ^= gap_p_required_type
	  then call ERROR_RETURN (error_table_$bad_subr_arg,
		  "^/Parameter ^d must be of type ^d, but the one given was ^d.", gap_p_arg_idx, gap_p_required_type,
		  gap_type);
         end;

      call cu_$arg_ptr_rel (gap_p_arg_idx, gap_arg_ptr, gap_arg_len, gap_code, gap_p_arg_list_ptr);
      if gap_code ^= 0
      then call ERROR_RETURN (gap_code, "^/Unable to get a pointer to parameter ^d.", gap_p_arg_idx);

      return (gap_arg_ptr);
   end GET_ARG_PTR;

%include vu_typed_vector_array;
%page;
%include desc_types;
%page;
%include sub_err_flags;
%page;
%include descriptor;
%page;
%include arg_list;
   end dm_vu_init_tva;




		    dm_vu_merge_tva.pl1             03/06/85  0751.0re  03/05/85  0756.0       55197



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

/* DESCRIPTION

          This routine takes a typed_vector_array and creates a new 
     typed_vector_array using using the caller provided id_list.
     The extent of the new dimension_table will
     be p_number_of_dimensions. This argument may be used to create "null"
     entries at the end of the dimension_table for later use. If more
     dimension ids are suplied than the requested number_of_dimensions or
     the extent of the old dimension_table, the remaining dimension_ids are
     ignored.
*/

/* HISTORY:

Written by Matthew Pierret 05/06/82.
Modified:
09/23/82 by Matthew Pierret:  Changed to use id_list instead of *-extent
            p_dimension_id array.
12/20/84 by Lindsey L. Spratt:  Moved the proc stmt to standard location.
            Updated DESCRIPTION, standardized the HISTORY section.  Changed
            null_info complaint to use error_table_$null_info_ptr and to be
            specific about which pointer is null.  Added cleanup handler,
            ERROR_FINISH (which frees the tva), and ERROR_RETURN.  Updated the
            sub_err_ calling sequence.  Commented the use of the (nosubrg)
            prefix.  Fixed CHECK_VERSION proc to have the cv_ prefix on its
            variables.
*/

/* format: style2,ind3 */
dm_vu_merge_tva:
   proc (p_work_area_ptr, p_number_of_dimensions, p_id_list_ptr, p_input_typed_vector_array_ptr,
        p_output_typed_vector_array_ptr, p_code);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_work_area_ptr	       ptr;
      dcl	    p_number_of_dimensions fixed bin (17);
      dcl	    p_id_list_ptr	       ptr;
      dcl	    p_input_typed_vector_array_ptr
			       ptr;
      dcl	    p_output_typed_vector_array_ptr
			       ptr;
      dcl	    p_code	       fixed bin (35);

/* Automatic */

      dcl	    accept_all_dimensions  bit (1) aligned init ("0"b);
      dcl	    dimension_idx	       fixed bin;
      dcl	    input_typed_vector_array_ptr
			       ptr;
      dcl	    work_area_ptr	       ptr;

/* Based */

/* Builtin */

      dcl	    (hbound, null, unspec) builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    myname	       init ("dm_vu_merge_tva") char (32) varying;

/* Entry */

      dcl	    dm_vector_util_$init_typed_vector_array
			       entry options (variable);
      dcl	    sub_err_	       entry options (variable);

/* External */

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

/* END OF DECLARATIONS */

      typed_vector_array_ptr = null;
      p_code = 0;
      work_area_ptr = p_work_area_ptr;
      input_typed_vector_array_ptr = p_input_typed_vector_array_ptr;

      on cleanup call ERROR_FINISH ();

      if input_typed_vector_array_ptr = null | work_area_ptr = null
      then call sub_err_ (error_table_$null_info_ptr, myname, ACTION_CANT_RESTART, null, 0,
	      "^/A null value was provided for^[ the work_area_ptr^;^]^[ and also^;^]^[ the input_typed_vector_array_ptr^;^]."
	      , (work_area_ptr = null), (work_area_ptr = null & input_typed_vector_array_ptr = null),
	      (input_typed_vector_array_ptr = null));

      if p_id_list_ptr = null
      then accept_all_dimensions = "1"b;
      else
         do;
	  id_list_ptr = p_id_list_ptr;
	  call CHECK_VERSION ((id_list.version), (ID_LIST_VERSION_1), "id_list");
         end;

      call dm_vector_util_$init_typed_vector_array (work_area_ptr, 0, p_number_of_dimensions,
	 input_typed_vector_array_ptr -> typed_vector_array.maximum_dimension_name_length, typed_vector_array_ptr,
	 p_code);
      if p_code ^= 0
      then call ERROR_RETURN (p_code);

      unspec (typed_vector_array.dimension_table) = ""b;

/* The (nosubrg) prefix is used below to avoid a compiler bug in the 
subscriptrange check, when checking an assignment of a single array element
between different based versions of the same structure.
(The check assumes the two version must have the same bounds.)
*/

      if accept_all_dimensions
      then
         do dimension_idx = 1 to input_typed_vector_array_ptr -> typed_vector_array.number_of_dimensions;
(nosubrg):
	  typed_vector_array.dimension_table (dimension_idx) =
	       input_typed_vector_array_ptr -> typed_vector_array.dimension_table (dimension_idx);
         end;
      else
         do dimension_idx = 1 to hbound (id_list.id, 1)
	    while (dimension_idx <= input_typed_vector_array_ptr -> typed_vector_array.number_of_dimensions);
(nosubrg):
	  typed_vector_array.dimension_table (dimension_idx) =
	       input_typed_vector_array_ptr -> typed_vector_array.dimension_table (id_list.id (dimension_idx));
         end;

      p_output_typed_vector_array_ptr = typed_vector_array_ptr;

MAIN_RETURN:
      return;


ERROR_RETURN:
   proc (er_p_code);
      dcl	    er_p_code	       fixed bin (35) parm;
      call ERROR_FINISH ();
      p_code = er_p_code;
      goto MAIN_RETURN;
   end ERROR_RETURN;


ERROR_FINISH:
   proc ();
      if typed_vector_array_ptr ^= null
      then free typed_vector_array;
   end ERROR_FINISH;

%page;
CHECK_VERSION:
   proc (cv_p_received_version, cv_p_expected_version, cv_p_structure_name);

      dcl	    cv_p_received_version  fixed bin (35);
      dcl	    cv_p_expected_version  fixed bin (35);
      dcl	    cv_p_structure_name    char (*);

      if cv_p_received_version ^= cv_p_expected_version
      then call sub_err_ (error_table_$unimplemented_version, myname, ACTION_CANT_RESTART, null, 0,
	      "^/Expected version ^d of the ^a structure.
Received version ^d, instead.", cv_p_expected_version, cv_p_structure_name, cv_p_received_version);

   end CHECK_VERSION;
%page;
%include sub_err_flags;
%page;
%include vu_typed_vector_array;
%page;
%include dm_id_list;

   end dm_vu_merge_tva;




		    dmsd_overseer_.pl1              08/05/87  0816.7r   08/04/87  1538.9      378810



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

/* DESCRIPTION:
This is the main procedure for the Data Management Daemon.  The Daemon runs
as a caretaker process for a Data Management system.  The Daemon creates an
IPC channel to receive requests from user's processes to perform various
functions on behalf of the users.  The Daemon handles abandoned transactions
and system recovery.  The Daemon initializes and controls the Data Management
system and schedules DM system shutdowns.  The Daemon requests the Answering
Service to send it notifications of process terminations over the Daemon's
request channel and the Daemon maintains an idle timer that also sends a
wakeup over the Daemon's request channel to periodically adjust the
transaction table.

This program has two entry points.
1. dmsd_overseer_ is the main entry point and is called by
   initialize_process_ when the daemon is to function in its normal capacity
   as a process overseer.  This entry never returns, QUITS are not allowed,
   Multics command level can not be reached, and the Daemon sits in a
   limited subsystem that only allows the commands new_proc and shutdown.

2. dmsd_overseer_$test is the command entry point used when a user wants
   to set up a test DM system with the user's current process as its Daemon.
   The limited subsystem listener of this entry points allows (..) escapes
   to Multics command level and the quit command.  QUITS are allowed and the
   command cleans up after itself when exited or released.

Since there are several steps that must be taken to set up a process
as a Daemon, and since the process may be interrupted at any point when the
Daemon is invoked as a command, the Daemon uses a system_state structure of
flags to record just how far the process has gone so that the FINISH routine
can know just what needs to be undane at clean up time.
*/

/* HISTORY:
Written by R. Michael Tague, 11/23/84.
Modified:
12/06/84 by R. Michael Tague: Changed dmsd_util_$* to dm_daemon_util_$* and
            call to dm_daemon_util_$unset_shutdown_timers.
12/09/84 by Lindsey Spratt: Changed to call dm_daemon_util_$log correctly.
            This subr requires that its first argument be a severity.
12/12/84 by R. Michael Tague: Fixed up in response to auditing comments.
12/13/84 by R. Michael Tague: Added SCHEDULE_SHUTDOWN ().
12/13/84 by R. Michael Tague: Changed name of dm_system_init_info.incl.pl1.
01/08/85 by Steve Herbst: Eliminated log initialization, values to be set
	  via dm_system_data_template_; fixed ring bracket in "Initializing
	  Data Management" message.
03/06/85 by Lee A. Newcomb:  Fixed the testing entry to reset the system
            directory to what it was when dmsd_overseer_ was invoked, not the
            constant >site>dm.  Removed unused variables and includes.
03/07/85 by Lee A. Newcomb:  Fixed so previous_system_dir is automatic, not
            internal static as I mistakenly made it in previous change.
03/07/85 by R. Michael Tague:  Fixed the ERROR_RETURN procedure to correctly
	  call com_err_ and sub_err_.
03/19/85 by R. Michael Tague:  Changed ssu name for process overseer to 
	  DM_Daemon_overseer instead of Daemon_no_prompt.
03/28/85 by Steve Herbst: Changed in response to audit, fixed calling
	  sequence of dm_daemon_util_$log.
04/02/85 by Lee A. Newcomb:  Fixed to set dm_daemon_util_$logout as the cl
            intermediary, the old practice of new_proc'ing led to new_proc
            looping.
04/09/85 by Lee A. Newcomb:  To use convert_access_class_ and not the obsolete
            convert_authorization_.
*/
/* format: style5,^indcomtxt */
%page;
dmsd_overseer_:
        proc (p_pit_pointer, p_call_listener_upon_return,
	  p_listener_command_line);

/* START OF DECLARATIONS */
/* Parameter */

        dcl     p_pit_pointer		ptr;
        dcl     p_call_listener_upon_return
				bit (1) aligned;
        dcl     p_listener_command_line char (*) varying;

/* Automatic */

        dcl     myname		char (32);
        dcl     previous_dm_system_dir	char (168) init ("");
					      /* must be set via a subr call */
        dcl     request_channel	fixed bin (71) init (0);
        dcl     saved_ips_mask	bit (36) aligned;
        dcl     saved_system_shutdown_handler
				ptr;
        dcl     ssu_system_ptr	ptr init (null ());
        dcl     system_dir_pathname	char (168);
        dcl     1 system_state	unaligned,
	        2 testing_error_return
				bit (1) init ("0"b),
	        2 system_dir_set	bit (1) init ("0"b),
	        2 shutdown_handler_set
				bit (1) init ("0"b),
	        2 dm_initialized	bit (1) init ("0"b);

/* Based */
/* Builtin */

        dcl     (addr, codeptr, fixed, min, null, size, unspec)
				builtin;

/* Condition */

        dcl     (cleanup, error, finish)
				condition;

/* Constant */

        dcl     BITS_PER_WORD		init (36) fixed bin internal
				static options (constant);
        dcl     DM_DAEMON_VERSION_1	init ("1") char (1) internal
				static options (constant);
        dcl     NOT_TESTING		init ("0"b) bit (1) internal
				static options (constant);
        dcl     TESTING		init ("1"b) bit (1) internal
				static options (constant);
        dcl     (NO_PAD, NO_NL)	init ("0"b) bit (1) aligned
				internal static options (constant);


/* Entry */

        dcl     com_err_		entry () options (variable);
        dcl     continue_to_signal_	entry (fixed bin (35));
        dcl     convert_access_class_$to_string
				entry (bit (72) aligned, char (*),
				fixed bin (35));
        dcl     create_ips_mask_	entry (ptr, fixed bin, bit (36) aligned)
				;
        dcl     cu_$arg_list_ptr	entry (ptr);
        dcl     cu_$arg_ptr		entry (fixed bin, ptr, fixed bin (21),
				fixed bin (35));
        dcl     cu_$generate_call	entry (entry, ptr);
        dcl     cu_$set_cl_intermediary entry (entry);
        dcl     dmsd_ssu_request_tables_$daemon_requests
				entry;
        dcl     dmsd_ssu_request_tables_$test_daemon_requests
				entry;
        dcl     dm_daemon_util_$log	entry () options (variable);
        dcl     dm_daemon_util_$logout	entry ();
        dcl     dm_daemon_util_$new_proc
				entry ();
        dcl     dm_daemon_util_$request entry;
        dcl     dm_daemon_util_$unset_shutdown_timers
				entry ();
        dcl     dm_daemon_util_$get_daemon_info
				entry (ptr);
        dcl     dm_daemon_util_$initialize_system
				entry (ptr);
        dcl     dm_daemon_util_$schedule_shutdown
				entry ();
        dcl     dm_misc_util_$get_system_dir
				entry (char (*));
        dcl     dm_misc_util_$is_process_using_dm
				entry () returns (bit (1) aligned);
        dcl     dm_misc_util_$set_system_dir
				entry (char (*));
        dcl     get_ring_		entry () returns (fixed bin (3));
        dcl     get_system_free_area_	entry () returns (ptr);
        dcl     get_authorization_	entry () returns (bit (72) aligned);
        dcl     hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin,
				char (*), fixed bin (35));
        dcl     hcs_$get_ring_brackets	entry (char (*), char (*),
				(3) fixed bin (3), fixed bin (35));
        dcl     hcs_$make_ptr		entry (ptr, char (*), char (*), ptr,
				fixed bin (35));
        dcl     hcs_$reset_ips_mask	entry (bit (36) aligned,
				bit (36) aligned);
        dcl     hcs_$set_ips_mask	entry (bit (36) aligned,
				bit (36) aligned);
        dcl     hcs_$wakeup		entry (bit (36) aligned, fixed bin (71),
				fixed bin (71), fixed bin (35));

        dcl     ioa_		entry options (variable);
        dcl     ioa_$rsnnl		entry options (variable);
        dcl     ioa_$general_rs	entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned);
        dcl     ipc_$create_ev_chn	entry (fixed bin (71), fixed bin (35));
        dcl     ipc_$decl_ev_call_chn	entry (fixed bin (71), entry, ptr,
				fixed bin, fixed bin (35));
        dcl     ipc_$delete_ev_chn	entry (fixed bin (71), fixed bin (35));
        dcl     message_segment_$add_file
				entry (char (*), char (*), ptr,
				fixed bin (18), bit (72) aligned,
				fixed bin (35));
        dcl     sct_manager_$get	entry (fixed bin, ptr, fixed bin (35));
        dcl     sct_manager_$set	entry (fixed bin, ptr, fixed bin (35));

        dcl     ssu_$cpescape_disabled	entry;
        dcl     ssu_$create_invocation	entry (char (*), char (*), ptr, ptr,
				char (*), ptr, fixed bin (35));
        dcl     ssu_$destroy_invocation entry (ptr);
        dcl     ssu_$listen		entry (ptr, ptr, fixed bin (35));
        dcl     ssu_$set_prompt_mode	entry (ptr, bit (*));
        dcl     ssu_$set_procedure	entry (ptr, char (*), entry,
				fixed bin (35));
        dcl     sub_err_		entry () options (variable);
        dcl     system_info_$request_chn
				entry (bit (36) aligned, fixed bin (71),
				char (*), char (*));
        dcl     timer_manager_$alarm_wakeup
				entry (fixed bin (71), bit (2),
				fixed bin (71));
        dcl     timer_manager_$reset_alarm_wakeup
				entry (fixed bin (71));
        dcl     transaction_manager_$user_shutdown
				entry (ptr, ptr, fixed bin (35));

/* External */
        dcl     dm_request_action_$adjust_process_id
				fixed bin (17) ext;
        dcl     error_table_$noarg	fixed bin (35) ext;
        dcl     error_table_$smallarg	fixed bin (35) ext;
        dcl     ssu_et_$subsystem_aborted
				fixed bin (35) ext;

/* Static */

/* END OF DECLARATIONS */
%page;
/* ************************************************************************
   * dmsd_overseer_ - This entry is called by initialize_process_ to act  *
   * as the process overseer for the Data Management Daemon.  A process   *
   * overseer is called with three parameters.  The local names and the   *
   * the functions of these paramenters follow:			    *
   * p_pit_pointer (input) - A pointer to the pit which is not used by    *
   *    this overseer.					    *
   * p_call_listener_upon_return (output) - A flag which if set to "1"b   *
   *    will cause initialize_process_ to call the listener_ should the   *
   *    overseer return.  If set to "0"b, a fatal process error will      *
   *    occur if the overseer returns.  Here this flag is set to "0"b,    *
   *    this overseer should never return.			    *
   * p_listener_command_line (output) - The command line that	    *
   *    initialize_process should pass to the listener if the overseer    *
   *    returns and p_call_listener_upon_return is set.		    *
   ************************************************************************ */

        call SET_CL_INTERMEDIARY;
        myname = "dmsd_overseer_";
        call SET_ERROR_RETURN (NOT_TESTING);

        call SET_UP_DAEMON ();
        on finish call FINISH_CONDITION_HANDLER;

        call COMMAND_LISTEN ();
        call ERROR_RETURN ();
%page;
/* *************************************************************************
   * dmsd_overseer_$test - This entry is a command entry for setting up    *
   * a Data Management Daemon in a user's process.  This command is used   *
   * for DM system and DM Daemon testing.  This command expects one	     *
   * argument which is the pathname of a directory that will become the    *
   * Data Management System directory.  The user should not be using DM    *
   * when this command is called.  If the user is using a DM system, he or *
   * she should use the dm_user_shutdown command first.		     *
   *     After establishing a DM system, this command enters a limited     *
   * subsystem enviornment.  This limited subsystem allows (..)  escapes   *
   * to Multics command level and the quit command.  Type: list_requests   *
   * while in the subsystem for a list of commands.		     *
   ************************************************************************ */

test:
        entry () options (variable);
        myname = "dmsd_overseer_$test";
        call SET_ERROR_RETURN (TESTING);
        call GET_ARGUMENT_PATHNAME (system_dir_pathname);
        call SET_SYSTEM_DIRECTORY (system_dir_pathname);
        on cleanup call FINISH ();

        call SET_UP_DAEMON ();

        call TEST_COMMAND_LISTEN ();
        call RETURN ();

MAIN_RETURN:
        return;
%page;
/* *************************************************************************
   * COMMAND_LISTEN - This is the ssu_ command listener for the normal     *
   * Daemon process overseer.  Except for a few standard subsystem	     *
   * commands, the only commands allowed are new_proc and shutdown.  	     *
   * Command processor escapes are not allowed and QUIT signals remain     *
   * masked.						     *
   ************************************************************************* */

COMMAND_LISTEN:
        proc ();
        dcl     cl_code		fixed bin (35);
        dcl     cl_version_str	char (10);

        call ioa_$rsnnl ("^i", cl_version_str, (0), DM_DAEMON_VERSION_1);
        call ssu_$create_invocation ("DM_Daemon_overseer", cl_version_str,
	  null (), codeptr (dmsd_ssu_request_tables_$daemon_requests), "",
	  ssu_system_ptr, cl_code);
        if cl_code ^= 0 then
	      call ERROR_RETURN (cl_code,
		"^/Cannot create a command listener subsystem.");
        else
	      do;
	      call ssu_$set_prompt_mode (ssu_system_ptr, DONT_PROMPT);
	      call ssu_$set_procedure (ssu_system_ptr, "cpescape",
		ssu_$cpescape_disabled, cl_code);
	      if cl_code ^= 0 then
		    call ERROR_RETURN (cl_code,
		        "^/Unable to disable (..) command processor escapes."
		        );
	      else
		    do;
		    call ssu_$listen (ssu_system_ptr, null (), cl_code);
		    call ERROR_RETURN (cl_code,
		        "^/Program Error.  Subsystem listener returned.");
		    end;
	      end;
        end COMMAND_LISTEN;
%page;
/* *************************************************************************
   * DESTROY_REQUEST_CHANNEL - This procedure is called to destroy the     *
   * Daemon request channel if one exits.  This only happens during FINISH *
   * for the $test command entry.				     *
   ************************************************************************* */

DESTROY_REQUEST_CHANNEL:
        proc ();
        dcl     drc_code		fixed bin (35);
        if request_channel ^= 0 then
	      call ipc_$delete_ev_chn (request_channel, drc_code);
        end DESTROY_REQUEST_CHANNEL;
%page;
/* *************************************************************************
   * DESTROY_SSU_INVOCATION - This procedure is called during FINISH for   *
   * the $test command entry to destroy the subsystem command invocation   *
   * if one exists.						     *
   ************************************************************************* */

DESTROY_SSU_INVOCATION:
        proc ();

        if ssu_system_ptr ^= null () then
	      call ssu_$destroy_invocation (ssu_system_ptr);
        end DESTROY_SSU_INVOCATION;
%page;
/* *************************************************************************
   * ERROR_RETURN -	This return is called only when when an error has	     *
   * occured and the Daemon cannot continue.  The procedure operates	     *
   * differently depending on the value of			     *
   * system_state.testing_error_return.  If the value is NOT_TESTING, the  *
   * normal value, then the error is reported via the DM log and sub_err_  *
   * and then the Daemon calls dm_daemon_util_$logout to logout the	     *
   * Daemon's process.  If the value is TESTING, then the error is	     *
   * reported via the DM log and com_err_ since the testing entry point is *
   * a command and then the Daemon executes FINISH and returns to the      *
   * user's command level.  The value of system_state.testing_error_return *
   * is set with a call to SET_ERROR_RETURN.			     *
   ************************************************************************* */

ERROR_RETURN:
        proc () options (variable);

        dcl     er_arg_list_ptr	ptr;
        dcl     er_based_error_code	fixed bin (35) based;
        dcl     1 er_err_msg_struc,
	        2 length		fixed bin (21),
	        2 string		char (1024);
        dcl     er_err_msg		varying char (1024)
				based (addr (er_err_msg_struc));

        call cu_$arg_list_ptr (er_arg_list_ptr);
        if er_arg_list_ptr -> arg_list.arg_count > 0 then
	      do;
	      if er_arg_list_ptr -> arg_list.arg_count > 1 then
		    call ioa_$general_rs (er_arg_list_ptr, 2, 3,
		        er_err_msg_struc.string, er_err_msg_struc.length,
		        NO_PAD, NO_NL);
	      else
		    er_err_msg = "";
	      call LOG_MESSAGE (ERROR_SV,
		er_arg_list_ptr -> arg_list.arg_ptrs (1)
		-> er_based_error_code, myname, er_err_msg);
	      end;
        if system_state.testing_error_return then
	      do;
	      call com_err_ (er_arg_list_ptr -> arg_list.arg_ptrs (1)
		-> er_based_error_code, myname, er_err_msg);
	      call FINISH;
	      end;
        else
	      do;
	      call sub_err_ (er_arg_list_ptr -> arg_list.arg_ptrs (1)
		-> er_based_error_code, myname, ACTION_CANT_RESTART, null,
		0, er_err_msg);
	      call dm_daemon_util_$logout;
	      end;
        goto MAIN_RETURN;
        end ERROR_RETURN;

LOG_MESSAGE:
        proc options (variable);
        dcl     lm_arg_list_ptr	ptr init (null);
        call cu_$arg_list_ptr (lm_arg_list_ptr);
        call cu_$generate_call (dm_daemon_util_$log, lm_arg_list_ptr);
        end LOG_MESSAGE;
%page;
/* *************************************************************************
   * FINISH - This procedure is called to finish up when the $test command *
   * exited normally of during an error return.  FINISH is also called as  *
   * a cleanup handler for the $test command.  FINISH is never called	     *
   * if we have entered through the normal Daemon overseer entry.	     *
   * Interrupts are	masked to prevent a QUIT during cleanup.  Anything     *
   * that was set up during  the execution of the command should be	     *
   * cleaned up after this by FINISH.  The values of flags in	     *
   * system_state controls just what needs to be cleaned up.	     *
   ************************************************************************* */

FINISH:
        proc ();
        dcl     f_code		fixed bin (35);

        call MASK_INTERRUPTS ();
        on error
	      begin;
	      call UNMASK_INTERRUPTS ();
	      call continue_to_signal_ (f_code);
	      if f_code ^= 0 then
		    call dm_daemon_util_$log (ERROR_SV, f_code, myname,
		        "continue_to_signal_ error in FINISH on unit.");
	      end;
        call dm_daemon_util_$unset_shutdown_timers ();
        call DESTROY_SSU_INVOCATION ();
        call UNSET_IDLE_TIMER ();
        call RESET_SYSTEM_SHUTDOWN_HANDLER ();
        call SHUTDOWN_DM_SYSTEM ();
        call DESTROY_REQUEST_CHANNEL ();
        call RESET_SYSTEM_DIRECTORY ();
        call UNMASK_INTERRUPTS ();
        end FINISH;
%page;
/* *************************************************************************
   * FINISH_CONDITION_HANDLER - This procedure is called from the main     *
   * Daemon as overseer entry point when a finish condition is signaled.   *
   * We simply log the fact that the Daemon is logging out and continue    *
   * the signal.						     *
   ************************************************************************* */

FINISH_CONDITION_HANDLER:
        proc ();
        dcl     fch_code		fixed bin (35);

        call ioa_ ("Data Management System Daemon logout.");
        call dm_daemon_util_$log (INFORM_SV,
	  "Data Management System Daemon logout.");
        call continue_to_signal_ (fch_code);
        if fch_code ^= 0 then
	      call ERROR_RETURN (fch_code,
		"^/Unable to continue to signal finish condition.");
        end FINISH_CONDITION_HANDLER;
%page;
/* *************************************************************************
   * GET_ARGUMENT_PATHNAME - Called by the $test entry to get the system   *
   * directory pathname argument that must be supplied to the command.     *
   ************************************************************************* */

GET_ARGUMENT_PATHNAME:
        proc (gap_pathname);
        dcl     gap_pathname		char (168);
        dcl     gap_arg_ptr		ptr;
        dcl     gap_arg_length	fixed bin (21);
        dcl     gap_argument		char (gap_arg_length)
				based (gap_arg_ptr);
        dcl     gap_code		fixed bin (35);

        call cu_$arg_ptr (1, gap_arg_ptr, gap_arg_length, gap_code);
        if gap_code ^= 0 then
	      call ERROR_RETURN (error_table_$noarg, "^/Syntax: ^a pathname",
		myname);
        else
	      gap_pathname = gap_argument;
        end GET_ARGUMENT_PATHNAME;
%page;
/* *************************************************************************
   * IDLE_TIME_IN_SECONDS - This function returns the the value of the DM  *
   * system parameter that specifies the amount of time between idle	     *
   * timeouts for the Daemon.  The time is converted from minutes to	     *
   * seconds and returned.					     *
   ************************************************************************* */

IDLE_TIME_IN_SECONDS:
        proc () returns (fixed bin);
        dcl     1 itis_daemon_info	aligned like dm_daemon_info;

        itis_daemon_info.version = DM_DAEMON_INFO_VERSION_1;
        call dm_daemon_util_$get_daemon_info (addr (itis_daemon_info));
        return (60 * itis_daemon_info.wakeup_increment);
        end IDLE_TIME_IN_SECONDS;
%page;
/* *************************************************************************
   * INITIALIZE_DM_SYSTEM - This procedure is called to initialize the DM  *
   * system.  After this call, the Data Management system is live.	     *
   * system_state.dm_initialized is set in this procedure.                 *
   ************************************************************************* */

INITIALIZE_DM_SYSTEM:
        proc ();
        dcl     1 ids_init_info	aligned like dm_system_init_info;

        ids_init_info.version = DM_SYSTEM_INIT_INFO_VERSION_1;
        ids_init_info.event_channel = request_channel;
        system_state.dm_initialized = "1"b;
        call dm_daemon_util_$initialize_system (addr (ids_init_info));
        end INITIALIZE_DM_SYSTEM;
%page;
/* *************************************************************************
   * LOG_DM_INITIALIZED - This procedure logs the fact that the DM system  *
   * has been initialized on the output channel and the DM system log.     *
   ************************************************************************* */

LOG_DM_INITIALIZED:
        proc ();

        call ioa_ ("Data Management System initialized.");
        call dm_daemon_util_$log (INFORM_SV,
	  "Data Management System initialized.");
        end LOG_DM_INITIALIZED;
%page;
/* *************************************************************************
   * LOG_DM_INITIALIZING - This procedure logs on the Daemon console log   *
   * that the Data Management system is about to be created.  We also      *
   * display what ring is the DM ring and the AIM classification.  We get  *
   * the ring number by getting a pointer to dm_daemon_gate_, converting   *
   * this pointer to a pathname, and then getting the write ring bracket   *
   * of dm_dameon_gate_.  The AIM classification string is displayed up to *
   * the first 100 characters.  Ellipsis is used to denote a longer	     *
   * classification string.					     *
   ************************************************************************* */

LOG_DM_INITIALIZING:
        proc ();

        dcl     ldi_classification_string
				char (100);
        dcl     ldi_code		fixed bin (35);
        dcl     ldi_daemon_gate_dir	char (168);
        dcl     ldi_daemon_gate_ptr	ptr;
        dcl     ldi_daemon_gate_seg	char (32);
        dcl     ldi_ring_brackets	(3) fixed bin (3);

        call hcs_$make_ptr (codeptr (dmsd_overseer_), "dm_daemon_gate_", "",
	  ldi_daemon_gate_ptr, ldi_code);
        if ldi_code ^= 0 then
	      call ERROR_RETURN (ldi_code,
		"^/Cannot get a pointer to dm_daemon_gate_.");
        call hcs_$fs_get_path_name (ldi_daemon_gate_ptr, ldi_daemon_gate_dir,
	  (0), ldi_daemon_gate_seg, ldi_code);
        if ldi_code ^= 0 then
	      call ERROR_RETURN (ldi_code,
		"^/Cannot get the pathname for dm_daemon_gate_.");
        call hcs_$get_ring_brackets (ldi_daemon_gate_dir, ldi_daemon_gate_seg,
	  ldi_ring_brackets, ldi_code);
        if ldi_code ^= 0 then
	      call ERROR_RETURN (ldi_code,
		"^/Cannot get the ring brackets of dm_daemon_gate_.");
        call convert_access_class_$to_string (get_authorization_ (),
	  ldi_classification_string, ldi_code);
        if ldi_code = error_table_$smallarg then
	      call ioa_ (
		"Initializing Data Management in ring ^i at^/^a . . .",
		min (ldi_ring_brackets (2), get_ring_ ()),
		ldi_classification_string);
        else if ldi_code = 0 then
	      call ioa_ (
		"Initializing Data Management in ring ^i^[^; at ^a^].",
		min (ldi_ring_brackets (2), get_ring_ ()),
		(ldi_classification_string = ""), ldi_classification_string)
		;
        else
	      call ERROR_RETURN (ldi_code,
		"^/Unable to get AIM classificaton.");
        end LOG_DM_INITIALIZING;
%page;
/* *************************************************************************
   * MAKE_REQUEST_CHANNEL_RECEIVER - This procedure creates an event call  *
   * channel so that DM users may make requests of the Daemon.  This	     *
   * channel is also used to receive idle timout wakeups and notifications *
   * of process terminations, both in the form of requests.		     *
   ************************************************************************* */

MAKE_REQUEST_CHANNEL_RECEIVER:
        proc ();
        dcl     mrcr_code		fixed bin (35);

        call ipc_$create_ev_chn (request_channel, mrcr_code);
        if mrcr_code ^= 0 then
	      call ERROR_RETURN (mrcr_code,
		"^/Cannot create request channel.");
        else
	      do;
	      call ipc_$decl_ev_call_chn (request_channel,
		dm_daemon_util_$request, null (), 0, mrcr_code);
	      if mrcr_code ^= 0 then
		    call ERROR_RETURN (mrcr_code,
		        "^/Cannot create request call channel.");
	      end;
        end MAKE_REQUEST_CHANNEL_RECEIVER;
%page;
/* *************************************************************************
   * MASK_INTERRUPTS - This routines masks all IPS interrupts and saves    *
   * the previous IPS mask in saved_ips_mask.			     *
   ************************************************************************* */

MASK_INTERRUPTS:
        proc ();
        dcl     mi_mask_names		(1) char (32);
        dcl     mi_mask		bit (36) aligned;

        mi_mask_names (1) = "-all";
        call create_ips_mask_ (addr (mi_mask_names), 1, mi_mask);
        call hcs_$set_ips_mask (mi_mask, saved_ips_mask);
        end MASK_INTERRUPTS;
%page;
/* *************************************************************************
   * REGISTER_FOR_PROC_TERM_NOTIFY - This procedure sends a message to the *
   * Answering Service over its request channel requesting that this	     *
   * process be registered to receive notifications upon the termination   *
   * of any process.  This is used so that the Daemon can abort any	     *
   * transaction that that process may have held when the process was      *
   * terminated.  The notifications from the Answering Service are sent as *
   * requests on the DM Daemon's request channel.			     *
   ************************************************************************* */

REGISTER_FOR_PROC_TERM_NOTIFY:
        proc ();
        dcl     mptr_code		fixed bin (35);
        dcl     1 mptr_proc_term_info	aligned like asr_buzzard_info;
        dcl     mptr_as_request_channel fixed bin (71);
        dcl     mptr_as_request_dir	char (168);
        dcl     1 mptr_as_request_message
				aligned
				like dm_adjust_process_id_word_1;
        dcl     mptr_as_request_proc	bit (36) aligned;
        dcl     mptr_as_request_seg	char (32);
        dcl     mptr_as_request_uid	bit (72) aligned;


        mptr_proc_term_info.header.version = as_request_version_1;
        mptr_proc_term_info.header.type = ASR_PROC_TERM_NOTIFY;
        mptr_proc_term_info.header.reply_channel = 0;
        mptr_proc_term_info.version = asr_buzzard_info_version_1;
        mptr_proc_term_info.info_channel = request_channel;
        mptr_as_request_message.action_type =
	  dm_request_action_$adjust_process_id;
        mptr_as_request_message.pad = 0;
        mptr_proc_term_info.my_reference_id = unspec (mptr_as_request_message);
        call system_info_$request_chn (mptr_as_request_proc,
	  mptr_as_request_channel, mptr_as_request_dir, mptr_as_request_seg);
        call message_segment_$add_file (mptr_as_request_dir,
	  mptr_as_request_seg, addr (mptr_proc_term_info),
	  BITS_PER_WORD * size (mptr_proc_term_info), mptr_as_request_uid,
	  mptr_code);
        if mptr_code ^= 0 then
	      call dm_daemon_util_$log (ERROR_SV, mptr_code, myname,
		"^/Cannot add to Answering Servce request message segment.^/Cannot receive process termination notifications."
		);
        else
	      do;
	      call hcs_$wakeup (mptr_as_request_proc, mptr_as_request_channel,
		fixed (mptr_as_request_uid), mptr_code);
	      if mptr_code ^= 0 then
		    call dm_daemon_util_$log (ERROR_SV, mptr_code, myname,
		        "^/Cannot send IPC wakeup to Answering Service.^/Cannot receive process termination notifications."
		        );
	      end;
        end REGISTER_FOR_PROC_TERM_NOTIFY;
%page;
/* *************************************************************************
   * RESET_SYSTEM_DIRECTORY - This procedure sets the DM system directory  *
   * to its default value.  If system_state.system_dir_set is true and     *
   * system_state.dm_initialized is false.  The system directory can only  *
   * be set if the DM system has been shutdown.  This procedure is called  *
   * during FINISH for the $test command.  The system directory is not     *
   * reset to its original value since it was not possible to get the	     *
   * previous value of the system directoy without risking an error.	     *
   *							     *
   * system_state.system_dir_set is reset in this procedure.	     *
   ************************************************************************* */

RESET_SYSTEM_DIRECTORY:
        proc ();
        if system_state.system_dir_set & ^system_state.dm_initialized then
	      do;
	      call dm_misc_util_$set_system_dir (previous_dm_system_dir);
	      system_state.system_dir_set = "0"b;
	      end;
        end RESET_SYSTEM_DIRECTORY;
%page;
/* *************************************************************************
   * RETURN - This is the normal return procedure for the $test command.   *
   * The Daemon as an overseer does not have a valid return, it should     *
   * never return.  A non-local goto MAIN_RETURN is performed to unwind    *
   * the stack.						     *
   ************************************************************************* */

RETURN:
        proc ();

        call FINISH ();
        goto MAIN_RETURN;
        end RETURN;
%page;
/* *************************************************************************
   * SCHEDULE_SHUTDOWN - This routine is called after the DM system has    *
   * been initialized.  It causes a DM system shutdown to be scheduled.    *
   ************************************************************************* */

SCHEDULE_SHUTDOWN:
        proc ();

        call dm_daemon_util_$schedule_shutdown ();
        end SCHEDULE_SHUTDOWN;
%page;
/* *************************************************************************
   * SET_CL_INTERMEDIARY - This procedure sets the system cl_intermediary  *
   * which is the default error handler called after printing the error    *
   * information.  This entry is used from the Daemon an overseer entry    *
   * point.  It is the setting of this procedure that prevents the	     *
   * Daemon's process from ever reaching Multics command level.  We handle *
   * this error by causing the Daemon to new_proc.		     *
   ************************************************************************* */

SET_CL_INTERMEDIARY:
        proc ();

        call cu_$set_cl_intermediary (dm_daemon_util_$logout);
        end SET_CL_INTERMEDIARY;
%page;
/* *************************************************************************
   * SET_ERROR_RETURN - This procedure sets the			     *
   * system_state.testing_error_return flag which controls what	     *
   * ERROR_RETURN does if it should be called.  The constants TESTING and  *
   * NOT_TESTING should be used when making the call to this routine.	     *
   ************************************************************************* */

SET_ERROR_RETURN:
        proc (ser_testing);
        dcl     ser_testing		bit (1);
        system_state.testing_error_return = ser_testing;
        end SET_ERROR_RETURN;
%page;
/* *************************************************************************
   * SET_IDLE_TIMER - This procedure is called to set a timeout wakeup to  *
   * go off sit_time_interval_seconds in the future.  This time interval   *
   * is set by the caller to the DM system parameter idle time.  When the  *
   * timer goes off it will send an alarm wakeup over the Daemon's request *
   * channel.						     *
   ************************************************************************* */

SET_IDLE_TIMER:
        proc (sit_time_interval_seconds);
        dcl     sit_time_interval_seconds
				fixed bin (71);
        dcl     SIT_RELATIVE_SECONDS_REQUEST
				bit (2) init ("11"b);

        call timer_manager_$alarm_wakeup (sit_time_interval_seconds,
	  SIT_RELATIVE_SECONDS_REQUEST, request_channel);
        end SET_IDLE_TIMER;
%page;
/* *************************************************************************
   * SET_SYSTEM_DIRECTORY - The procedure is called to set the DM system   *
   * directory to a specified pathname. We check to see if the user is     *
   * currently using a Data Management system before trying to set the     *
   * system directory.  dm_misc_util_$set_system_dir will not set the	     *
   * system directory if the process is currenty using DM.  This is only   *
   * called from the $test command entry point.			     *
   *							     *
   * The system_state.system_dir_set flag is set in this procedure.	     *
   ************************************************************************* */

SET_SYSTEM_DIRECTORY:
        proc (ssd_pathname);
        dcl     ssd_pathname		char (168);

        if dm_misc_util_$is_process_using_dm () then
	      call ERROR_RETURN (0,
		"^/User must execute dm_user_shutdown before trying to^/create another DM system."
		);
        else
	      do;
	      call dm_misc_util_$get_system_dir (previous_dm_system_dir);
	      system_state.system_dir_set = "1"b;
	      call dm_misc_util_$set_system_dir (ssd_pathname);
	      end;
        end SET_SYSTEM_DIRECTORY;
%page;
/* *************************************************************************
   * SET_SYSTEM_SHUTDOWN_HANDLER - This procedure saves the current	     *
   * system_shutdown_scheduled_ IPS signal handler in the global variable  *
   * saved_system_shutdown_handler and then changes the current handler to *
   * be the handler appropriate for the DM daemon.  The DM Daemon handler  *
   * will reschedule DM shutdown whenever it receives a		     *
   * system_shutdown_scheduled_ IPS from the Answering Service.	     *
   * The system_state.shutdown_handler_set flag is set here.	     *
   ************************************************************************* */

SET_SYSTEM_SHUTDOWN_HANDLER:
        proc ();
        dcl     sssh_code		fixed bin (35);

        call sct_manager_$get (system_shutdown_scheduled_sct_index,
	  saved_system_shutdown_handler, sssh_code);
        if sssh_code ^= 0 then
	      call ERROR_RETURN (sssh_code,
		"^/Cannot get the current system_shutdown_scheduled_ handler."
		);
        else
	      do;
	      system_state.shutdown_handler_set = "1"b;
	      call sct_manager_$set (system_shutdown_scheduled_sct_index,
		codeptr (dm_daemon_util_$schedule_shutdown), sssh_code);
	      if sssh_code ^= 0 then
		    call ERROR_RETURN (sssh_code,
		        "^/Cannot set the system_shutdown_scheduled_ handler."
		        );
	      end;
        end SET_SYSTEM_SHUTDOWN_HANDLER;
%page;
/* *************************************************************************
   * SET_UP_DAEMON - This procedure does all that is necessary to set up   *
   * as a Data Management system and Daemon.			     *
   ************************************************************************* */

SET_UP_DAEMON:
        proc ();

        call LOG_DM_INITIALIZING ();
        call MAKE_REQUEST_CHANNEL_RECEIVER ();
        call INITIALIZE_DM_SYSTEM ();
        call SET_SYSTEM_SHUTDOWN_HANDLER ();
        call SCHEDULE_SHUTDOWN ();
        call REGISTER_FOR_PROC_TERM_NOTIFY ();
        call SET_IDLE_TIMER (IDLE_TIME_IN_SECONDS ());
        call LOG_DM_INITIALIZED ();
        end SET_UP_DAEMON;
%page;
/* *************************************************************************
   * SHUTDOWN_DM_SYSTEM - This procedure is called by FINISH to close down *
   * the DM system if there is one.  This only happens in the $test	     *
   * command entry.  This procedure must get and free an area because the  *
   * transaction_manager_$user_shutdown procedure needs an area pointer to *
   * allocate a structure in that we do not use.  If the		     *
   * system_state.dm_initialized flag is set, then shutdown is performed   *
   * and the flag is reset.					     *
   ************************************************************************* */

SHUTDOWN_DM_SYSTEM:
        proc ();
        dcl     1 sds_shutdown_info	aligned like tm_shutdown_info
				based (tm_shutdown_info_ptr);
        dcl     sds_code		fixed bin (35);

        if system_state.dm_initialized then
	      do;
	      call transaction_manager_$user_shutdown (
		get_system_free_area_ (), tm_shutdown_info_ptr, sds_code);
	      if sds_code ^= 0 then
		    call com_err_ (sds_code, myname,
		        "^/Cannot shutdown test DM system.");
	      else
		    do;
		    free sds_shutdown_info;
		    system_state.dm_initialized = "0"b;
		    end;
	      end;
        end SHUTDOWN_DM_SYSTEM;
%page;
/* *************************************************************************
   * TEST_COMMAND_LISTEN - This is the ssu_ listener for the Daemon when   *
   * invoked as a test command through the $test entry.  This command      *
   * listener differers from the Daemon as overseer command listener in    *
   * that it allow (..) escapes to Multics command level, and has a quit   *
   * command.  QUITS are allowed because they are allowed anytime during   *
   * the execution of the $test command entry.  The error code	     *
   * ssu_et_$subsystem_aborted is the normal error code return from	     *
   * ssu_$listen when a quit command has been typed.  The subsystem	     *
   * invocation has to be destroyed in the FINISH procedure.	     *
   ************************************************************************* */

TEST_COMMAND_LISTEN:
        proc ();
        dcl     tcl_code		fixed bin (35);
        dcl     tcl_version_str	char (10);

        call ioa_$rsnnl ("^i", tcl_version_str, (0), DM_DAEMON_VERSION_1);
        call ssu_$create_invocation ("DM_Daemon", tcl_version_str, null (),
	  codeptr (dmsd_ssu_request_tables_$test_daemon_requests), "",
	  ssu_system_ptr, tcl_code);
        if tcl_code ^= 0 then
	      call ERROR_RETURN (tcl_code,
		"^/Cannot create a command listener subsystem.");
        else
	      do;
	      call ssu_$listen (ssu_system_ptr, null (), tcl_code);
	      if tcl_code ^= ssu_et_$subsystem_aborted then
		    call ERROR_RETURN (tcl_code,
		        "^/Subsystem listener returned with error.");
	      end;
        end TEST_COMMAND_LISTEN;
%page;
/* *************************************************************************
   * UNMASK_INTERRUPTS - This procedure restores the IPS mask to its saved *
   * value.						     *
   ************************************************************************* */

UNMASK_INTERRUPTS:
        proc ();

        call hcs_$reset_ips_mask (saved_ips_mask, (""b));
        end UNMASK_INTERRUPTS;
%page;
/* *************************************************************************
   * UNSET_IDLE_TIMER - Eliminates any idle timout that may be pending.    *
   ************************************************************************* */

UNSET_IDLE_TIMER:
        proc ();

        if request_channel ^= 0 then
	      call timer_manager_$reset_alarm_wakeup (request_channel);
        end UNSET_IDLE_TIMER;
%page;
/* *************************************************************************
   * RESET_SYSTEM_SHUTDOWN_HANDLER  If system_state.shutdown_handler_set   *
   * indicated that the system_shutdown_scheduled_ IPS handler was set,    *
   * this procedure resets it to its previous value and resets the	     *
   * system_state flag.					     *
   ************************************************************************* */

RESET_SYSTEM_SHUTDOWN_HANDLER:
        proc ();
        dcl     ussh_code		fixed bin (35);

        if system_state.shutdown_handler_set then
	      do;
	      call sct_manager_$set (system_shutdown_scheduled_sct_index,
		saved_system_shutdown_handler, ussh_code);
	      if ussh_code ^= 0 then
		    call com_err_ (ussh_code, myname,
		        "^/Cannot reset the system_shutdown_shceduled_ IPS handler."
		        );
	      else
		    system_state.shutdown_handler_set = "0"b;
	      end;
        end RESET_SYSTEM_SHUTDOWN_HANDLER;
%page;
%include arg_list;
%page;
%include as_request_header;
%page;
%include as_requests;
%page;
%include dm_log_sv_codes;
%page;
%include dm_request_message;
%page;
%include dm_system_init_info;
%page;
%include dm_tm_shutdown_info;
%page;
%include dm_daemon_info;
%page;
%include ssu_prompt_modes;
%page;
%include static_handlers;
%page;
%include sub_err_flags;

        end dmsd_overseer_;




		    dmsd_ssu_request_tables_.alm    11/05/86  1221.9r w 11/04/86  1037.8       26838



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" dmsd_ssu_request_tables_
" These are the ssu_ request tables for the Data Management Daemon's
" limited subsystem listener.
"
" Written by R. Michael Tague, 11/27/84.
" Modified:
" 12/17/84 by R. Michael Tague: Added the summarize_requests (?) request.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	dmsd_ssu_request_tables_
	include	ssu_request_macros

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" daemon_requests - This table is used when the DM Daemon is being used
" as a process_overseer_, i.e., a real Daemon, not a test Daemon.
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	begin_table	daemon_requests

	request	help,
		ssu_requests_$help,
		(),
		(Obtain detailed information on the subsystem.)

	request	list_help,
		ssu_requests_$list_help,
		(lh),
		(List topics for which help is available.)

	request	list_requests,
		ssu_requests_$list_requests,
		(lr),
		(List brief information on subsystem requests.)

	request	?,
		ssu_requests_$summarize_requests,
		(),
		(Produce a list of the most commonly used requests.)

	request	.,
		ssu_requests_$self_identify,
		(),
		(Identify the subsystem.)

	request	new_proc,
		dm_daemon_util_$new_proc,
		(),
		(Destroy current process and get a new one.)

	request	shutdown,
		dm_system_shutdown$shutdown_request,
		(),
		(Shutdown this Data Management system.)

	end_table	daemon_requests

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" test_daemon_requests - This table is used by a DM daemon that has been
" invoked as a command in a test enviornment.  The test Daemon has one
" more command, quit.
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	begin_table	test_daemon_requests

	request	help,
		ssu_requests_$help,
		(),
		(Obtain detailed information on the subsystem.)

	request	list_help,
		ssu_requests_$list_help,
		(lh),
		(List topics for which help is available.)

	request	list_requests,
		ssu_requests_$list_requests,
		(lr),
		(List brief information on subsystem requests.)

	request	?,
		ssu_requests_$summarize_requests,
		(),
		(Produce a list of the most commonly used requests.)

	request	quit,
		ssu_requests_$quit,
		(q),
		(Leave the subsystem.)

	request	.,
		ssu_requests_$self_identify,
		(),
		(Identify the subsystem.)

	request	new_proc,
		dm_daemon_util_$new_proc,
		(),
		(Destroy current process and get a new one.)

	request	shutdown,
	    	dm_system_shutdown$shutdown_request,
		(),
		(Shutdown this Data Management system.)

	end_table test_daemon_requests

	end




		    file_manager_.alm               04/04/85  1114.9re  04/04/85  0824.7       63414



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"
" DESCRIPTION:
"
"	 This is the main transfer vector for the file manager primitives.
"    NOTE:  any entry that goes through one of the dm gates should have a
"    prefix of "fm_" on the entrypoint name (e.g. dm_gate_$fm_put), any
"    entry that goes straight to the target program should (obviously) use
"    the exact target entrypoint name (obviously, e.g.,
"    fm_validate_$fm_validate_), any entry that goes through
"    fm_firstref_tv_ should NOT prefix the entrypoint name with "fm_"
"    (e.g., fm_firstref_tv_$put_journal).  THIS IS THE CONVENTION THAT
"    HAS BEEN SET UP AND CAUSES PROBLEMS IF NOT FOLLOWED.
"
" HISTORY:
"
" Written by Jeffrey D. Ives,	09/27/82.
" Modified:
" 01/25/83 by Jeffrey D. Ives:  changed it to call dm_fm_gate_.
" 02/23/83 by Jeffrey D. Ives:  changed it to call fm_gate_.
" 03/02/83 by S. Herbst:  added attribute primitives to be called by
"	    object_type_.
" 03/28/83 by Lindsey Spratt:  changed delentry_file to simply transfer to
"	    the same entry as delete (fm_gate_$delete).
" 03/29/83 by S. Herbst:  added $copy, and changed $delentry_file to
"	    call delete_dm_file_.
" 04/19/83 by Jeffrey D. Ives:  changed from tra to call6 so that gates work.
" 09/14/83 by Lee A. Newcomb:  to not go through fm_gate_ when
"	    per_system_init is called.
" 12/22/83 by Matthew Pierret:  Removed the acl_delete, acl_list and
"	    acl_replace entries, which were unused.  The acl_add
"	    entry should also be removed when the
"	    before_journal_manager_ is taught to use the standard
"	    add_acl_entries entry instead.
" 01/04/84 by L. A. Newcomb:  replaced fm_gate_ with dm_gate_ to save segno's.
" 02/01/84 by Matthew Pierret:  Added $get_ci_ptr and $terminate_ci_ptr.
" 05/02/84 by Lee A. Newcomb:  Added $user_shutdown.
" 05/21/84 by R. Michael Tague:  Removed $acl_delete, $acl_list, and
"	    $acl_replace.  Changed $adopt and $open_by_uid_after_crash to
"	    call through dm_daemon_gate_.  Changed $put_journal, $undo,
"	    and $unput to transfer directly to the fm_inner_ring_tv_.
"	    Changed $fetch and $store to $simple_get and $simple_put.
"	    Changed $read and $write to $get_stream and $put_stream.
" 05/24/84 by Lee A. Newcomb:  fixed $fm_put_journal, $fm_undo, and
"	    $fm_unput  by removing "fm_" prefix as they go through the
"	    inner ring TV, fixed $simple_get and $simple_put by adding
"	    the "fm_" prefix as they go through a gate.
" 05/25/84 by R. Michael Tague:  Changed $abandon to call
"	    fm_inner_ring_tv_$abandon.
" 06/25/84 by Matthew Pierret:  Removed $acl_add.
" 07/17/84 by Matthew Pierret:  Added $post_transaction.
" 10/29/84 by Matthew Pierret:  Changed post_commit to postcommit_do.
" 11/22/84 by Lee A. Newcomb:  Added $per_process_init entry.
" 11/14/84 by Matthew Pierret:  Added $add_extended_acl_entries, $get_bit_count
"             $list_extended_acl, $replace_extended_acl, and $set_bit_count.
"             Made $get_ring_brackets and $set_ring_brackets transfer to
"             something real instead of nothing$nothing.
"             Made $get_stream and $put_stream go through dm_gate_.
"             Changed $post_commit to $postcommit_do.
" 12/03/84 by Stanford S. Cox: Chg *inner_ring_tv_ to =firstref_tv_.
" 03/13/85 by R. Michael Tague:  Added postcommit_increment.
" 03/29/85 by R. Michael Tague:  Fixed $postcommit_increment to go through
"	    dm_gate_.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	macro	transfer
	entry	&1
&1:
	call6	&2

	&end


	transfer	abandon,fm_firstref_tv_$abandon
	transfer	add_acl_entries,dm_gate_$fm_add_acl_entries
          transfer  add_extended_acl_entries,dm_gate_$fm_add_extended_acl_entries
	transfer	adopt,dm_daemon_gate_$fm_adopt
	transfer	allocate,dm_gate_$fm_allocate
	transfer	chname_file,dm_gate_$fm_chname_file
	transfer	close,dm_gate_$fm_close
	transfer	copy,copy_dm_file_$copy_dm_file_
	transfer	create,dm_gate_$fm_create
	transfer	create_open,dm_gate_$fm_create_open
	transfer	delentry_file,delete_dm_file_$delete_dm_file_
	transfer	delete,dm_gate_$fm_delete
	transfer	delete_acl_entries,dm_gate_$fm_delete_acl_entries
	transfer	delete_close,dm_gate_$fm_delete_close
	transfer	end_of_crash_recovery,dm_daemon_gate_$fm_end_of_crash_recovery
	transfer	find_old_uid_pn_table,dm_daemon_gate_$fm_find_old_uid_pn_table
	transfer	flush_consecutive_ci,dm_gate_$fm_flush_consecutive_ci
	transfer	flush_modified_ci,dm_gate_$fm_flush_modified_ci
	transfer	free,dm_gate_$fm_free
	transfer	get,dm_gate_$fm_get
          transfer  get_bit_count,dm_gate_$fm_get_bit_count
	transfer	get_ci_header,dm_gate_$fm_get_ci_header
          transfer  get_ci_ptr,dm_gate_$fm_get_ci_ptr
	transfer	get_exclusive,dm_gate_$fm_get_exclusive
	transfer	get_max_length,dm_gate_$fm_get_max_length
	transfer	get_ring_brackets,dm_gate_$fm_get_ring_brackets
	transfer  get_stream,dm_gate_$fm_get_stream
	transfer	get_switch,dm_gate_$fm_get_switch
	transfer	get_user_access_modes,dm_gate_$fm_get_user_access_modes
	transfer	list_acl,dm_gate_$fm_list_acl
	transfer	list_extended_acl,dm_gate_$fm_list_extended_acl
	transfer	list_switches,dm_gate_$fm_list_switches
	transfer	lock_advice,dm_gate_$fm_lock_advice
	transfer	open,dm_gate_$fm_open
	transfer	open_by_uid,dm_gate_$fm_open_by_uid
	transfer	open_by_uid_after_crash,dm_daemon_gate_$fm_open_by_uid_after_crash
	transfer	per_process_init,fm_firstref_tv_$per_process_init
	transfer	per_system_init,fm_per_system_init_$fm_per_system_init_
          transfer  postcommit_do,fm_firstref_tv_$postcommit_do
	transfer  postcommit_increment,dm_gate_$fm_postcommit_increment
          transfer  post_transaction,fm_firstref_tv_$post_transaction
	transfer	prepare_to_copy,dm_gate_$fm_prepare_to_copy
	transfer	put,dm_gate_$fm_put
	transfer	put_journal,fm_firstref_tv_$put_journal
	transfer  put_stream,dm_gate_$fm_put_stream
	transfer	raw_get,dm_gate_$fm_raw_get
	transfer	raw_put,dm_gate_$fm_raw_put
 	transfer	replace_acl,dm_gate_$fm_replace_acl
 	transfer	replace_extended_acl,dm_gate_$fm_replace_extended_acl
	transfer	set_bit_count,dm_gate_$fm_set_bit_count
	transfer	set_max_length,dm_gate_$fm_set_max_length
	transfer	set_ring_brackets,dm_gate_$fm_set_ring_brackets
	transfer	set_switch,dm_gate_$fm_set_switch
	transfer	simple_get,dm_gate_$fm_simple_get
	transfer  simple_put,dm_gate_$fm_simple_put
	transfer	status,dm_gate_$fm_status
	transfer	sub_err_flag_get,dm_gate_$fm_sub_err_flag_get
	transfer	sub_err_flag_set,dm_gate_$fm_sub_err_flag_set
	transfer	suffix_info,dm_gate_$fm_suffix_info
          transfer  terminate_ci_ptr,dm_gate_$fm_terminate_ci_ptr
	transfer	undo,fm_firstref_tv_$undo
	transfer	unput,fm_firstref_tv_$unput
	transfer	user_shutdown,fm_firstref_tv_$user_shutdown
	transfer	validate,dm_gate_$fm_validate


	end




		    fm_attribute_.pl1               04/24/85  1016.3re  04/24/85  0803.2      281772



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

/* DESCRIPTION:

          This module and the module fm_attribute_fref_ together contain
     all operations which deal with Data Management files as file system
     objects.  These operations mimic the operations in the suffix_chess_
     example in MTB-671.
     These operations are the eventual targets of entries in
     fs_util_, the file system utility for handling file system objects
     and extended objects. fm_attribute_fref_ contains those operations
     which require the process to be using Data Management - per-process
     initialization will be executed if it has not already been executed.
     This module, fm_attribute_, contains those operations which do not
     require the process to be using Data Management.
*/

/* HISTORY:

Written by Steve Herbst, 02/25/83.
            (Copied from mbx_suffix_.)
Modified:
03/25/83 by S. Herbst:  Deleted $delentry_file (file_manager_ will call 
            file_manager_$delete), fixed bugs.
05/23/83 by S. Herbst:  Fixed $suffix_info to return modes of "rew".
06/17/83 by S. Herbst:  Changed $suffix_info to set new copy_flags.
06/28/83 by S. Herbst:  Changed to use copy_flags.incl.pl1.
07/07/83 by S. Herbst:  Fixed ACL entries to reject modes other than r, rw, 
            and null.
07/20/83 by S. Herbst:  Fixed $get_user_access_modes to return the mode on 
            the 1st component.
08/18/83 by S. Herbst:  Added suffix_info.info_pathname.
10/25/83 by L. Spratt: Added sub_error_ handler to validate_proc to turn any 
            sub_error_ into a not_seg_type error .
12/12/83 by Lee Baldwin:  Changed the description and history sections to the
            canonical format.
12/13/83 by Lee Baldwin:  Moved ACL primitives from fm_open_ to this
            procedure.  Changed entries which require validation to use
            fm_validate_ instead of validate_proc.  Removed the "open" and
            "validate_proc" routines.  Removed the format: off stmt.
12/22/83 by Matthew Pierret:  Changed to return dm_error_$file_not_dm_type if
            the call to fm_validate_ fails.
03/16/84 by Matthew Pierret:  Changed to return dm_error_$file_not_dm_type
            only if fm_validate_ returns error_table_$not_seg_type.
07/30/84 by Matthew Pierret:  Changed to check extended ring brackets.
11/13/84 by Matthew Pierret:  Split into fm_attribute_ and fm_attribute_fref_.
            Moved get_switch and chname_file to fm_attribute_fref_.
            Changed list_switches to return the protection, concurrency and
            rollback switches.
12/06/84 by Matthew Pierret:  Changed RETURN to set p_code to 0.  Changed
            list_switches to not call RETURN as it does not have a p_code.
            Added declaration for rtrim, removed several declarations of 
            un-used variables.
12/07/84 by Lee A. Newcomb:  Removed rtrim usage in pathname_ calls.
12/20/84 by Matthew Pierret:  Changed several entries to match the calling
            sequences of suffix_chess_ in MTB671, which fm_attribute_ and
            fm_attribute_fref_ are intended to duplicate.
            add_acl_entries - removed p_acl_count, made to accept only
            p_acl_ptr->general_acl, convert general_acl to segment_acl_array
            for use by msf_manager_$acl_add;
            add_extended_acl_entries - changed p_exmodes to p_acl_ptr;
            delete_acl_entries - removed p_arg_count, made to accept only
            p_acl_ptr->general_acl, convert general_acl to delete_acl_array;
            get_user_access_modes - to set validation level;
            list_acl - removed p_listed_acl_ptr, p_explicit_acl_ptr and
            p_acl_count in favor of p_acl_ptr, made to correctly interpret
            input values (null p_acl_ptr means get everything, non-null
            p_acl_ptr means get whats in p_acl_ptr->general_acl, null
            p_user_area_ptr means allocate in get_user_free_area_()), made
            to convert to and from segment_acl_array around calls to
            msf_manager_, add p_version_wanted parameter;
            list_extended_acl - add p_version_wanted parameter;
            list_switches - added short names of switches, add p_code and
            p_version_wnated parameters, made to use get_user_free_area_() if 
            p_user_area_ptr is null;
            replace_acl - removed p_acl_count, made to only accept
            general_acl, to convert general_acl to segment_acl_array;
            replace_extended_acl - removed p_acl_count.
12/26/84 by Matthew Pierret: Changed suffix_info to set type, standard_object,
            and num_ring_brackets.
01/03/85 by Lee A. Newcomb:  Fixed $get_user_access_modes to set p_modes
            return parameter instead of leaving it null; fixed "Written by"
            HISTORY line so subsys_add_journalization.ec works.
01/04/85 by Matthew Pierret:  Fixed replace_acl's one incorrect use of
            segment_acl to the correct general_acl.  Changed suffix_info
            to return a max_mode_len of 3 (instead of 2) and the mode string
            "r w" (instead of "rw").  This change allows callers to use
            the standard access mode constants.
05/12/85 by S. Cox: (add delete)_acl_entries/replace_acl: Chg so the DM daemon 
	  will always have 'rw' access, overriding whatever the user gave.
04/16/85 by Lindsey L. Spratt:  Added initializtion to "null()" for all of the
            automatic pointers.  Initializing msf_ptr to null fixed a bug in
            calls to the FINISH proc where spurious attempts to close the
            (non-existent) msf identified by the (garbage) msf_ptr caused
            random faults.  Added initialization to UNSET_VALIDATION_LEVEL of
	  the callers_validation_level.  These initializations were being 
	  done in the INIT_FOR_FINISH proc, but not all entries remembered
	  to call INIT_FOR_FINISH.  Doing the inits in the declarations
	  guarantees that the initializations are done, rather than rely on
	  each entry to remember to call INIT_FOR_FINISH.
	       Changed suffix_info entry to turn off the copy flags for
	  max_length, and the copy and dumper switches.  Changed uses of
	  "1"b and "0"b to YES and NO, respectively.
*/

/* format: style2,ind3 */
%page;
fm_attribute_$suffix_info:
   procedure (p_suffix_info_ptr);


/* Parameter */

      dcl	    p_acl_ptr	       pointer parameter;
      dcl	    p_bit_count	       fixed bin (24) parameter;
      dcl	    p_code	       fixed bin (35) parameter;
      dcl	    p_ename	       char (*) parameter;
      dcl	    p_exmodes	       bit (36) aligned parameter;
      dcl	    p_dirname	       char (*) parameter;
      dcl	    p_max_length	       fixed bin (19) parameter;
      dcl	    p_modes	       bit (36) aligned parameter;
      dcl	    p_no_sysdaemon	       bit (1) parameter;
      dcl	    p_ring	       fixed bin parameter;
      dcl	    p_ring_brackets	       (2) fixed bin (3) parameter;
      dcl	    p_suffix_info_ptr      pointer parameter;
      dcl	    p_switch_list_ptr      ptr parameter;
      dcl	    p_switch_name	       char (*) parameter;
      dcl	    p_switch_value	       bit (1) parameter;
      dcl	    p_user_area_ptr	       pointer parameter;
      dcl	    p_user_name	       char (*) parameter;
      dcl	    p_version_wanted       char (*) parameter;

/* Automatic */

      dcl	    dirname	       char (168);
      dcl	    ename		       char (32);
      dcl	    user_name	       char (64);
      dcl	    version_wanted	       char (8) aligned;

      dcl	    delete_acl_array_ptr   ptr init (null ());
      dcl	    msf_ptr	       ptr init (null ());
      dcl	    segment_acl_array_ptr  ptr init (null ());
      dcl	    system_area_ptr	       ptr init (null ());
      dcl	    user_area_ptr	       ptr init (null ());


      dcl	    acl_idx	       fixed bin;
      dcl	    callers_validation_level
			       fixed bin init (UNSET_VALIDATION_LEVEL);
      dcl	    attempt_to_change_daemon_access
			       bit (1) aligned init (NO);
      dcl	    code		       fixed bin (35) init (0);
      dcl	    extended_ring_brackets (2) fixed bin (3);
      dcl	    exmodes	       bit (36) aligned;
      dcl	    mode_bits	       bit (3);
      dcl	    modes		       bit (36) aligned;
      dcl	    no_sysdaemon	       bit (1);
      dcl	    ring		       fixed bin;

/* Based */

      dcl	    user_area	       area based (user_area_ptr);
      dcl	    system_area	       area based (system_area_ptr);

/* Builtins */

      dcl	    (null, string, substr, unspec)
			       builtin;

/* Condition */

      dcl	    cleanup	       condition;

/* Constant */

      dcl	    (
	    READ_BRACKET_IDX       init (2),
	    WRITE_BRACKET_IDX      init (1)
	    )		       fixed bin internal static options (constant);
/**** Cannot use dm_system_data_$initializer_name since it sets off the fref */
      dcl	    DM_INITIALIZER_NAME    char (32) aligned static options (constant) init ("Data_Management.Daemon.*");
      dcl	    UNSET_VALIDATION_LEVEL init (-1) fixed bin internal static options (constant);
      dcl	    (
	    NO		       init ("0"b),
	    YES		       init ("1"b)
	    )		       bit (1) aligned internal static options (constant);

/* Entry */

      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    cu_$level_set	       entry (fixed bin);
      dcl	    fm_validate_$check_read_ring_bracket
			       entry (char (*), char (*), fixed bin (35));
      dcl	    fm_validate_$check_write_ring_bracket
			       entry (char (*), char (*), fixed bin (35));
      dcl	    fm_validate_$get_ring_brackets
			       entry (char (*), char (*), (2) fixed bin (3), fixed bin (35));
      dcl	    get_ring_	       entry returns (fixed bin);
      dcl	    get_system_free_area_  entry () returns (ptr);
      dcl	    get_user_free_area_    entry () returns (ptr);
      dcl	    hcs_$get_user_access_modes
			       entry (char (*), char (*), char (*), fixed bin, bit (36) aligned, bit (36) aligned,
			       fixed bin (35));
      dcl	    msf_manager_$acl_add   entry (ptr, ptr, fixed bin, fixed bin (35));
      dcl	    msf_manager_$acl_delete
			       entry (ptr, ptr, fixed bin, fixed bin (35));
      dcl	    msf_manager_$acl_list  entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin (35));
      dcl	    msf_manager_$acl_replace
			       entry (ptr, ptr, fixed bin, bit (1), fixed bin (35));
      dcl	    msf_manager_$close     entry (ptr);
      dcl	    msf_manager_$open      entry (char (*), char (*), ptr, fixed bin (35));
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));

/* External */

      dcl	    dm_error_$file_not_dm_type
			       fixed bin (35) ext;
      dcl	    error_table_$invalid_mode
			       fixed bin (35) ext;
      dcl	    error_table_$not_seg_type
			       fixed bin (35) ext;
      dcl	    error_table_$unimplemented_version
			       fixed bin (35) ext;
      dcl	    error_table_$unsupported_operation
			       fixed bin (35) ext;
%page;
/* DESCRIPTION OF suffix_info ENTRY:

        Returns generic information about DM files.  
   p_suffix_info_ptr must point to a suffix_info structure which has
   its version element set.
*/

/* The actual entry is the main procedure statement. 
   It is repeated here for clarity.

suffix_info:
   entry (p_suffix_info_ptr);
*/

      suffix_info_ptr = p_suffix_info_ptr;

      suffix_info.version = SUFFIX_INFO_VERSION_1;
      suffix_info.type = FS_OBJECT_TYPE_DM_FILE;
      suffix_info.type_name = "DM file";
      suffix_info.plural_name = "DM files";
      string (suffix_info.flags) = ""b;
      suffix_info.standard_object = YES;
      suffix_info.extended_acl = NO;
      suffix_info.modes = "r w";
      suffix_info.max_mode_len = 3;
      suffix_info.num_ring_brackets = 2;

      unspec (suffix_info.copy_flags) = ""b;
      suffix_info.copy_flags.names = YES;
      suffix_info.copy_flags.acl = YES;
      suffix_info.copy_flags.max_length = NO;
      suffix_info.copy_flags.copy_switch = NO;
      suffix_info.copy_flags.safety_switch = NO;
      suffix_info.copy_flags.dumper_switches = NO;

      suffix_info.info_pathname = "";

MAIN_RETURN:
      return;

RETURN:
   proc ();

      p_code = 0;
      go to MAIN_RETURN;

   end RETURN;

ERROR_RETURN:
   proc (er_p_code);

      dcl	    er_p_code	       fixed bin (35) parameter;

      p_code = er_p_code;
      call FINISH ();
      go to MAIN_RETURN;

   end ERROR_RETURN;

FINISH:
   proc ();

      if msf_ptr ^= null ()
      then call msf_manager_$close (msf_ptr);
      if delete_acl_array_ptr ^= null
      then
         do;
	  free delete_acl_array_ptr -> delete_acl_array;
	  delete_acl_array_ptr = null ();
         end;
      if segment_acl_array_ptr ^= null ()
      then
         do;
	  free segment_acl_array_ptr -> segment_acl_array;
	  segment_acl_array_ptr = null ();
         end;
      if callers_validation_level ^= UNSET_VALIDATION_LEVEL
      then call cu_$level_set (callers_validation_level);

   end FINISH;
%page;
/* DESCRIPTION OF add_acl_entries ENTRY:
   
        Adds ACL entries to a DM file.
   
   p_dirname is the pathname of the directory containing the DM file.
   p_ename is the entry name of the DM file.
   p_acl_ptr points to a general_acl structure containing the new
             ACL entries.
   p_code is an output status code.
*/

add_acl_entries:
   entry (p_dirname, p_ename, p_acl_ptr, p_code);

      dirname = p_dirname;
      ename = p_ename;
      acl_ptr = p_acl_ptr;

      code = 0;

      if acl_ptr -> general_acl.version ^= GENERAL_ACL_VERSION_1
      then call ERROR_RETURN (error_table_$unimplemented_version);

      acl_count = acl_ptr -> general_acl.count;
      do acl_idx = 1 to acl_count;			/* check for invalid DM file modes */
         mode_bits = substr (acl_ptr -> general_acl.entries (acl_idx).mode, 1, 3);
         if mode_bits ^= R_ACCESS & mode_bits ^= RW_ACCESS & mode_bits ^= N_ACCESS
         then call ERROR_RETURN (error_table_$invalid_mode);
      end;

      call fm_validate_$check_write_ring_bracket (dirname, ename, code);
      if code ^= 0
      then if code = error_table_$not_seg_type
	 then call ERROR_RETURN (dm_error_$file_not_dm_type);
	 else call ERROR_RETURN (code);

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();
      call cu_$level_set (get_ring_ ());

      system_area_ptr = get_system_free_area_ ();

      allocate segment_acl_array in (system_area) set (segment_acl_array_ptr);

      segment_acl_array_ptr -> segment_acl_array.access_name (*) = acl_ptr -> general_acl.entries.access_name (*);
      segment_acl_array_ptr -> segment_acl_array.mode (*) = acl_ptr -> general_acl.entries.mode (*);
      segment_acl_array_ptr -> segment_acl_array.extended_mode (*) = ""b;
      segment_acl_array_ptr -> segment_acl_array.status_code (*) = acl_ptr -> general_acl.entries.status_code (*);

      do acl_idx = 1 to acl_count
	 while (segment_acl_array_ptr -> segment_acl_array (acl_idx).access_name ^= DM_INITIALIZER_NAME);
      end;
      if acl_idx <= acl_count				/* daemon access must be rw */
      then segment_acl_array_ptr -> segment_acl_array (acl_idx).mode = RW_ACCESS;

      call msf_manager_$open (dirname, ename, msf_ptr, code);
      if msf_ptr = null
      then call ERROR_RETURN (code);

      call msf_manager_$acl_add (msf_ptr, segment_acl_array_ptr, acl_count, code);
      if code ^= 0
      then call ERROR_RETURN (code);


      call FINISH ();

      call RETURN ();
%page;
/* DESCRIPTION OF add_extended_acl_entries ENTRY:  Unsupported */

add_extended_acl_entries:
   entry (p_dirname, p_ename, p_acl_ptr, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);


/*  DESCRIPTION OF delete_acl_entries ENTRY:
   
        Deletes ACL entries from a DM file.
   
   p_dirname is the pathname of the directory containing the DM file.
   p_ename is the entry name of the DM file.
   p_acl_ptr points to a general_acl structure containing the 
             ACL entries to be deleted.
   p_code is an output status code.

*/

delete_acl_entries:
   entry (p_dirname, p_ename, p_acl_ptr, p_code);

      dirname = p_dirname;
      ename = p_ename;
      acl_ptr = p_acl_ptr;

      code = 0;
      attempt_to_change_daemon_access = NO;

      if acl_ptr -> general_acl.version ^= GENERAL_ACL_VERSION_1
      then call ERROR_RETURN (error_table_$unimplemented_version);

      acl_count = acl_ptr -> general_acl.count;

      call fm_validate_$check_write_ring_bracket (dirname, ename, code);
      if code ^= 0
      then if code = error_table_$not_seg_type
	 then call ERROR_RETURN (dm_error_$file_not_dm_type);
	 else call ERROR_RETURN (code);

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();
      call cu_$level_set (get_ring_ ());

      system_area_ptr = get_system_free_area_ ();

      alloc delete_acl_array in (system_area) set (delete_acl_array_ptr);

      delete_acl_array_ptr -> delete_acl_array.access_name (*) = acl_ptr -> general_acl.entries.access_name (*);
      delete_acl_array_ptr -> delete_acl_array.status_code (*) = acl_ptr -> general_acl.entries.status_code (*);

      do acl_idx = 1 to acl_count
	 while (delete_acl_array_ptr -> delete_acl_array (acl_idx).access_name ^= DM_INITIALIZER_NAME);
      end;
      if acl_idx <= acl_count
      then attempt_to_change_daemon_access = YES;		/* explicitly readd daemon access */

      call msf_manager_$open (dirname, ename, msf_ptr, code);
      if msf_ptr = null
      then call ERROR_RETURN (code);

      call msf_manager_$acl_delete (msf_ptr, delete_acl_array_ptr, acl_count, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if attempt_to_change_daemon_access
      then
         do;
	  allocate segment_acl_array in (system_area) set (segment_acl_array_ptr);
	  unspec (segment_acl_array_ptr -> segment_acl_array) = ""b;
	  segment_acl_array_ptr -> segment_acl_array.access_name (1) = DM_INITIALIZER_NAME;
	  segment_acl_array_ptr -> segment_acl_array.mode (1) = RW_ACCESS;
	  call msf_manager_$acl_add (msf_ptr, segment_acl_array_ptr, (1), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;

      call FINISH ();

      call RETURN ();
%page;
/* DESCRIPTION OF get_bit_count ENTRY:  Unsupported. */

get_bit_count:
   entry (p_dirname, p_ename, p_bit_count, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);

/* DESCRIPTION OF get_max_length ENTRY:  Unsupported. */

get_max_length:
   entry (p_dirname, p_ename, p_max_length, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);
%page;
/* DESCRIPTION OF get_ring_brackets ENTRY:

        Gets the file ring brackets of the DM file.  The file ring brackets
   are maintained by file_manager_ and are not necessarily the same as the
   file system ring brackets.  The file ring brackets are stored in two
   places: the file_attributes in the file and in an encoded form as the
   bit count of the file's first component.  This entry gets the encoded
   ring brackets, which can be referenced without requiring per-process
   initialization.
*/

get_ring_brackets:
   entry (p_dirname, p_ename, p_ring_brackets, p_code);

      dirname = p_dirname;
      ename = p_ename;

      code = 0;

      call fm_validate_$get_ring_brackets (dirname, ename, extended_ring_brackets, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      p_ring_brackets (*) = extended_ring_brackets (*);

      call RETURN ();
%page;
/* DESCRIPTION OF get_user_access_modes ENTRY:

        Gets the access modes and extended access modes (not yet supported) 
   of a DM file for a user.
*/

get_user_access_modes:
   entry (p_dirname, p_ename, p_user_name, p_ring, p_modes, p_exmodes, p_code);

      dirname = p_dirname;
      ename = p_ename;
      user_name = p_user_name;
      ring = p_ring;


      code = 0;
      p_modes = ""b;
      p_exmodes = ""b;				/* Not supported */

      call fm_validate_$get_ring_brackets (dirname, ename, extended_ring_brackets, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();
      call cu_$level_set (get_ring_ ());

      call hcs_$get_user_access_modes (pathname_ (dirname, ename), "0", user_name, get_ring_ (), modes, exmodes, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if ring <= extended_ring_brackets (WRITE_BRACKET_IDX)
      then modes = (modes & RW_ACCESS);
      else if ring <= extended_ring_brackets (READ_BRACKET_IDX)
      then modes = (modes & R_ACCESS);
      else modes = ""b;

      call FINISH ();

      p_modes = modes;
      call RETURN ();
%page;
/* DESCRIPTION OF list_acl ENTRY:
   
        Lists ACL entries on a DM file.

   p_dirname is the pathname of the directory containing the DM file.
   p_ename is the entry name of the DM file.
   p_version_wanted is the version of the structure to be returned.
             Only GENERAL_ACL_VERSION_1 is supported.
   p_user_area_ptr is a pointer to an area in which to allocate the return
             if one must be allocated.  If null, get_user_free_area_() is used.
   p_acl_ptr is a pointer to a general_acl structure.  If null, the general_acl
             structure is allocated in the user area and contains all of the
             ACL entries on the file.  If non-null, then p_acl_ptr->general_acl
             is filled in with the ACL entries specified by
             p_acl_ptr->general_acl.entries.access_name(*).
   p_code is an output status code.

   */

list_acl:
   entry (p_dirname, p_ename, p_version_wanted, p_user_area_ptr, p_acl_ptr, p_code);

      dirname = p_dirname;
      ename = p_ename;
      version_wanted = p_version_wanted;
      user_area_ptr = p_user_area_ptr;
      acl_ptr = p_acl_ptr;


      code = 0;

      if acl_ptr = null ()
      then if version_wanted ^= GENERAL_ACL_VERSION_1
	 then call ERROR_RETURN (error_table_$unimplemented_version);
	 else acl_count = 0;
      else if acl_ptr -> general_acl.version ^= GENERAL_ACL_VERSION_1
      then call ERROR_RETURN (error_table_$unimplemented_version);
      else acl_count = acl_ptr -> general_acl.count;

      call fm_validate_$check_read_ring_bracket (dirname, ename, code);
      if code ^= 0
      then if code = error_table_$not_seg_type
	 then call ERROR_RETURN (dm_error_$file_not_dm_type);
	 else call ERROR_RETURN (code);

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();
      call cu_$level_set (get_ring_ ());

      call msf_manager_$open (dirname, ename, msf_ptr, code);
      if msf_ptr = null
      then call ERROR_RETURN (code);

      system_area_ptr = get_system_free_area_ ();
      if acl_ptr ^= null ()
      then
         do;
	  alloc segment_acl_array in (system_area) set (segment_acl_array_ptr);
	  segment_acl_array_ptr -> segment_acl_array.access_name (*) = acl_ptr -> general_acl.entries.access_name (*);

	  call msf_manager_$acl_list (msf_ptr, null (), null (), segment_acl_array_ptr, acl_count, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  acl_ptr -> general_acl.entries.access_name (*) = segment_acl_array_ptr -> segment_acl_array.access_name (*);
	  acl_ptr -> general_acl.entries.mode (*) = segment_acl_array_ptr -> segment_acl_array.mode (*);
	  acl_ptr -> general_acl.entries.status_code (*) = segment_acl_array_ptr -> segment_acl_array.status_code (*);

         end;
      else
         do;
	  call msf_manager_$acl_list (msf_ptr, system_area_ptr, segment_acl_array_ptr, null (), acl_count, code);
	  if code ^= 0
	  then call ERROR_RETURN (code);

	  if user_area_ptr = null
	  then user_area_ptr = get_user_free_area_ ();

	  alloc general_acl in (user_area) set (acl_ptr);

	  acl_ptr -> general_acl.version = version_wanted;
	  acl_ptr -> general_acl.entries.access_name (*) = segment_acl_array_ptr -> segment_acl_array.access_name (*);
	  acl_ptr -> general_acl.entries.mode (*) = segment_acl_array_ptr -> segment_acl_array.mode (*);
	  acl_ptr -> general_acl.entries.status_code (*) = segment_acl_array_ptr -> segment_acl_array.status_code (*);
         end;

      p_acl_ptr = acl_ptr;

      call FINISH ();

      call RETURN ();


/* DESCRIPTION OF list_extended_acl ENTRY:  Unsupported. */

list_extended_acl:
   entry (p_dirname, p_ename, p_version_wanted, p_user_area_ptr, p_acl_ptr, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);
%page;
/* DESCRIPTION OF list_switches ENTRY:
     
        Returns names of non-standard switches.  Three switches are
   supported: protection, concurrency and rollback.

   p_version_wanted is the version of the switch_list to be returned.
             Only SWITCH_LIST_VERSION_1 is supported.   
   p_user_area_ptr points to the area in which the output switch_list structure
             is to be allocated.  If null, get_user_free_area_() is used.
   p_switch_list_ptr is set to point to the allocated switch_list structure.
   p_code is a status code.
*/

list_switches:
   entry (p_version_wanted, p_user_area_ptr, p_switch_list_ptr, p_code);

      version_wanted = p_version_wanted;
      user_area_ptr = p_user_area_ptr;



      if version_wanted ^= SWITCH_LIST_VERSION_1
      then call ERROR_RETURN (error_table_$unimplemented_version);
      if user_area_ptr = null
      then user_area_ptr = get_user_free_area_ ();

      alloc_switch_count = 3;
      alloc_switch_name_count = 6;
      allocate switch_list in (user_area);

      switch_list.version = SWITCH_LIST_VERSION_1;

      switch_list.switches (1).name_index = 1;
      switch_list.switches (1).name_count = 2;
      switch_list.switches (1).default_value = YES;
      switch_list.switches (1).mbz1 = ""b;
      switch_list.names (1) = "protection";
      switch_list.names (2) = "prot";

      switch_list.switches (2).name_index = 2;
      switch_list.switches (2).name_count = 2;
      switch_list.switches (2).default_value = YES;
      switch_list.switches (2).mbz1 = ""b;
      switch_list.names (3) = "concurrency";
      switch_list.names (4) = "conc";

      switch_list.switches (3).name_index = 3;
      switch_list.switches (3).name_count = 2;
      switch_list.switches (3).default_value = YES;
      switch_list.switches (3).mbz1 = ""b;
      switch_list.names (5) = "rollback";
      switch_list.names (6) = "rlb";

      p_switch_list_ptr = switch_list_ptr;

      call RETURN ();
%page;
/* DESCRIPTION OF replace_acl ENTRY:

        Replaces the ACL of a DM file.

      p_dirname is the pathname of the directory containing the DM file.
      p_ename is the entry anem of the DM file.
      p_acl_ptr points to the general_acl structure which is the new ACL.
      p_pno_sysdaemon indicates, if on, to ignore the SysDaemon ACL entry.
      p_code is a status code.
 */

replace_acl:
   entry (p_dirname, p_ename, p_acl_ptr, p_no_sysdaemon, p_code);

      dirname = p_dirname;
      ename = p_ename;
      acl_ptr = p_acl_ptr;
      no_sysdaemon = p_no_sysdaemon;

      code = 0;
      attempt_to_change_daemon_access = NO;

      if acl_ptr = null
      then acl_count = 1;				/* allow one for readding daemon */
      else
         do;
	  if acl_ptr -> general_acl.version ^= GENERAL_ACL_VERSION_1
	  then call ERROR_RETURN (error_table_$unimplemented_version);
	  acl_count = acl_ptr -> general_acl.count;
	  do acl_idx = 1 to acl_count;		/* check for invalid DM file modes */
	     mode_bits = substr (acl_ptr -> general_acl.entries (acl_idx).mode, 1, 3);
	     if mode_bits ^= R_ACCESS & mode_bits ^= RW_ACCESS & mode_bits ^= N_ACCESS
	     then call ERROR_RETURN (error_table_$invalid_mode);
	  end;
         end;

      call fm_validate_$check_write_ring_bracket (dirname, ename, code);
      if code ^= 0
      then if code = error_table_$not_seg_type
	 then call ERROR_RETURN (dm_error_$file_not_dm_type);
	 else call ERROR_RETURN (code);

      call cu_$level_get (callers_validation_level);
      on cleanup call FINISH ();
      call cu_$level_set (get_ring_ ());

      call msf_manager_$open (dirname, ename, msf_ptr, code);
      if msf_ptr = null
      then call ERROR_RETURN (code);

      system_area_ptr = get_system_free_area_ ();

      if acl_ptr = null ()				/* daemon must be on acl */
      then
         do;
	  allocate segment_acl_array in (system_area) set (segment_acl_array_ptr);
	  unspec (segment_acl_array_ptr -> segment_acl_array) = ""b;
	  segment_acl_array_ptr -> segment_acl_array.access_name (1) = DM_INITIALIZER_NAME;
	  segment_acl_array_ptr -> segment_acl_array.mode (1) = RW_ACCESS;
         end;
      else
         do;
	  allocate segment_acl_array in (system_area) set (segment_acl_array_ptr);
	  segment_acl_array_ptr -> segment_acl_array.access_name (*) = acl_ptr -> general_acl.entries.access_name (*);
	  segment_acl_array_ptr -> segment_acl_array.mode (*) = acl_ptr -> general_acl.entries.mode (*);
	  segment_acl_array_ptr -> segment_acl_array.extended_mode (*) = ""b;
	  segment_acl_array_ptr -> segment_acl_array.status_code (*) = acl_ptr -> general_acl.entries.status_code (*);

	  do acl_idx = 1 to acl_count
	       while (segment_acl_array_ptr -> segment_acl_array (acl_idx).access_name ^= DM_INITIALIZER_NAME);
	  end;
	  if acl_idx <= acl_count
	  then segment_acl_array_ptr -> segment_acl_array (acl_idx).mode = RW_ACCESS;
	  else attempt_to_change_daemon_access = YES;	/* daemon not specified so explicitly readd it */
         end;

      call msf_manager_$acl_replace (msf_ptr, segment_acl_array_ptr, acl_count, no_sysdaemon, code);
      if code ^= 0
      then call ERROR_RETURN (code);

      if attempt_to_change_daemon_access
      then
         do;
	  unspec (segment_acl_array_ptr -> segment_acl_array) = ""b;
	  segment_acl_array_ptr -> segment_acl_array.access_name (1) = DM_INITIALIZER_NAME;
	  segment_acl_array_ptr -> segment_acl_array.mode (1) = RW_ACCESS;
	  call msf_manager_$acl_add (msf_ptr, segment_acl_array_ptr, (1), code);
	  if code ^= 0
	  then call ERROR_RETURN (code);
         end;

      call FINISH ();

      call RETURN ();

/* DESCRIPTION OF replace_extended_acl ENTRY:  Unsupported: */

replace_extended_acl:
   entry (p_dirname, p_ename, p_acl_ptr, p_no_sysdaemon, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);
%page;

/* DESCRIPTION OF set_bit_count ENTRY:  Unsupported. */

set_bit_count:
   entry (p_dirname, p_ename, p_bit_count, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);


/* DESCRIPTION OF set_max_length ENTRY:  Unsupported. */

set_max_length:
   entry (p_dirname, p_ename, p_max_length, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);

/* DESCRIPTION OF set_switch ENTRY:  Unsupported. */

set_switch:
   entry (p_dirname, p_ename, p_switch_name, p_switch_value, p_code);

      call ERROR_RETURN (error_table_$unsupported_operation);
%page;
%include acl_structures;
%page;
%include access_mode_values;
%page;
%include copy_flags;
%page;
%include suffix_info;

   end fm_attribute_$suffix_info;




		    fm_no_firstref_tv_.alm          01/04/85  0952.6re  01/03/85  1151.0       19188



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"  DESCRIPTION:
"
"          This is one of the two Data Management file manager transfer
"     vectors.  This one, fm_no_firstref_tv_, is for each file manager entry
"     which does not require Data Management per-process initialization to 
"     have been executed at some time before the file manager entry itself is
"     executed.  Entries which require Data Management per-process 
"     initialization go through fm_firstref_tv_, which has a first
"     reference trap is associated with fm_firstref_tv_ which runs per-process
"     initialization the first time fm_firstref_tv_ is invoked.
"
" HISTORY:
"
" Written by Matthew Pierret, 11/13/84.
" Modified:
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	name	fm_no_firstref_tv_

	macro	transfer
	entry	&1
&1:
	tra	&2

	&end


	transfer	add_acl_entries,fm_attribute_$add_acl_entries
          transfer  add_extended_acl_entries,fm_attribute_$add_extended_acl_entries
	transfer	delete_acl_entries,fm_attribute_$delete_acl_entries
          transfer  get_bit_count,fm_attribute_$get_bit_count
	transfer	get_max_length,fm_attribute_$get_max_length
          transfer  get_ring_brackets,fm_attribute_$get_ring_brackets
	transfer	get_user_access_modes,fm_attribute_$get_user_access_modes
	transfer	list_acl,fm_attribute_$list_acl
          transfer  list_extended_acl,fm_attribute_$list_extended_acl
	transfer	list_switches,fm_attribute_$list_switches
	transfer	replace_acl,fm_attribute_$replace_acl
          transfer  replace_extended_acl,fm_attribute_$replace_extended_acl
	transfer	set_bit_count,fm_attribute_$set_bit_count
	transfer	set_max_length,fm_attribute_$set_max_length
	transfer	set_switch,fm_attribute_$set_switch
	transfer	suffix_info,fm_attribute_$suffix_info
          transfer  validate,fm_validate_$fm_validate_

	end




		    fm_per_system_init_.pl1         01/04/85  0952.6re  01/03/85  1151.0       13707



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

/*  DESCRIPTION

	This module creates the file_manager_'s UID-pathname table during
     the first part of a Data Management System's initialization.  This
     used to reside in fm_combos_.pl1 and was pulled out to not conflict
     with the per-process initialization first reference traps.
*/

/* HISTORY:
Written by Jeffrey D. Ives, 02/23/83.
Modified:
08/06/83 by Lee A. Newcomb:  removed obsolete code args. from calls
	  to dm_per_system_ entries.
05/30/84 by Lee A. Newcomb:  fixed formatting to pass audit.
*/

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */
%page;
fm_per_system_init_:
     proc (p_code);

/* START OF DECLARATIONS */
/* Parameter */

dcl
     p_code		        fixed bin (35) parameter;

/* Automatic */

dcl
     seg_ptr		        ptr automatic;

/* Based */
/* Builtins */
/* Conditions */
/* Constants */
/* Entries */

dcl
     dm_per_system_$create	        entry (char (*), ptr);

/* External Static */
/* Internal Static */

/* END OF DECLARATIONS */


	call dm_per_system_$create ("fm_sys_pn_tbl", seg_ptr);

	seg_ptr -> sys_pn_tbl.h.version = SYS_PN_TBL_VERSION_1;
	p_code = 0;

	return;
%page; %include dm_fm_sys_pn_tbl;

     end fm_per_system_init_;




		    fm_validate_.pl1                04/09/85  1537.6r w 04/08/85  1128.0       77877



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


/* DESCRIPTION:

   This  module  validates  whether an entry is a data management file.
   If the  module  is  a  DM  file,  a  0  code  is  returned.    Otherwise,
   the following codes are returned:

     error_table$noentry - File does not exist and user has "s" access to the
         file's containing directory;
     error_table_$no_info - User does not have "s" access to the file's
          containing directory and does not have "r" access to the file's
	first component;
     error_table_$not_seg_type - File does not have the canonical add-name
          on the first component which identifies it as a DM file, or, the
	write-ring-bracket on the first component is not the DM ring (here
	defined as the ring of execution of this module).
*/

/* HISTORY:

Written by Lee Baldwin, 12/13/83.
Modified:
12/22/83 by Matthew Pierret:  Changed to check for the special add-name on the
            first component instead of a special link.
02/28/84 by Matthew Pierret:  Changed contract to return non-not_seg_type
            error codes in certain situations, specifically (a) if the file
            does not exist, (b) the user does not have enough access to do the
            validation.
03/08/84 by Matthew Pierret:  Fixed call to pathname_ to first rtrim the 
            directory path argument.
03/12/84 by Matthew Pierret:  Changed to rtrim the p_entry_name argument.
07/11/84 by Matthew C. Pierret:  some changes.  
11/01/84 by Matthew Pierret:  Fixed expression which incorrectly diagnosed
            caller_validation_level < read_bracket as an error, instead
            of using >.
11/08/84 by Matthew C. Pierret:  Removed an unnecessary rtrim and removed
            declarations of un-used variables.
*/
/* format: style2 */
%page;
fm_validate_:
     proc (p_dir_path, p_entry_name, p_code);

/* START OF DECLARATIONS */
/* Parameter */

	dcl     p_dir_path		 char (*);	/* the name of the directory containing the
						   DM file. */
	dcl     p_entry_name	 char (*);	/* the entry name of the DM file. */
	dcl     p_code		 fixed bin (35);	/* a standard system status code. */
	dcl     p_ring_brackets	 (2) fixed bin (3);

/* Automatic */

	dcl     (check_read, check_write, get_ring_brackets, no_status_permission)
				 bit (1) aligned init ("0"b);

	dcl     code		 fixed bin (35) init (0);
	dcl     containing_containing_dir_path
				 char (168);
	dcl     containing_dir_path	 char (168);
	dcl     containing_dir_name	 char (32);
	dcl     file_name		 char (32);
	dcl     file_path		 char (168);
	dcl     bit_count		 fixed bin (24);
	dcl     caller_validation_level
				 fixed bin;
	dcl     current_validation_level
				 fixed bin;
	dcl     mode		 fixed bin (5);
	dcl     ring_brackets	 (3) fixed bin (3);
	dcl     extended_ring_brackets (2) fixed bin (3);
	dcl     type		 fixed bin (2);

/* Based */
/* Builtin */

	dcl     (divide, mod, rtrim)	 builtin;

/* Condition */

	dcl     cleanup		 condition;

/* Constant */

	dcl     myname		 init ("fm_validate_") char (32) varying internal static options (constant);
	dcl     DONT_CHASE_LINK	 init (0) fixed bin (1) internal static options (constant);
	dcl     (
	        WRITE_BRACKET	 init (1),
	        READ_BRACKET	 init (2)
	        )			 fixed bin internal static options (constant);
	dcl     FIRST_COMPONENT_NAME	 init ("0") char (1) internal static options (constant);

/* Entry */

	dcl     cu_$level_get	 entry (fixed bin);
	dcl     cu_$level_set	 entry (fixed bin);
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_ring_		 entry () returns (fixed bin);
	dcl     hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35));
	dcl     hcs_$get_user_effmode	 entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));

/* External */

	dcl     error_table_$no_info	 ext fixed bin (35);
	dcl     error_table_$no_s_permission
				 ext fixed bin (35);
	dcl     error_table_$no_r_permission
				 ext fixed bin (35);
	dcl     error_table_$no_w_permission
				 ext fixed bin (35);
	dcl     error_table_$not_seg_type
				 ext fixed bin (35);

/* END OF DECLARATIONS */

/* format: indcomtxt,^indblkcom */

	go to JOIN;

check_write_ring_bracket:
     entry (p_dir_path, p_entry_name, p_code);

	check_write = "1"b;
	check_read = "1"b;
	get_ring_brackets = "1"b;
	go to JOIN;

check_read_ring_bracket:
     entry (p_dir_path, p_entry_name, p_code);

	check_write = "0"b;
	check_read = "1"b;
	get_ring_brackets = "1"b;
	go to JOIN;

get_ring_brackets:
     entry (p_dir_path, p_entry_name, p_ring_brackets, p_code);

	check_write = "0"b;
	check_read = "0"b;
	get_ring_brackets = "1"b;
	go to JOIN;
%page;
JOIN:
/**** Set the validation level to the ring of execution. */
	call cu_$level_get (caller_validation_level);
	on cleanup call cu_$level_set (caller_validation_level);
	current_validation_level = get_ring_ ();
	call cu_$level_set (current_validation_level);

/**** Set up the file pathname */

	containing_dir_path = rtrim (p_dir_path);
	file_name = rtrim (p_entry_name);
	file_path = pathname_ (containing_dir_path, file_name);

/**** Verify that entry exists and process has at least minimal access. */

	call hcs_$status_minf (containing_dir_path, file_name, DONT_CHASE_LINK, type, (0), code);
	if code ^= 0 & code ^= error_table_$no_s_permission
	then call ERROR_RETURN (code);

/**** Verify that process has at least "s" permission on the containing
      directory (containing_dir_path) or "r" permission on the first MSF component. */

	code = 0;
	call expand_pathname_ (containing_dir_path, containing_containing_dir_path, containing_dir_name, code);
	if code ^= 0
	then call ERROR_RETURN (code);
	call hcs_$get_user_effmode (containing_containing_dir_path, containing_dir_name,
	     "" /* defaults to calling process */, current_validation_level, mode, code);
	if code ^= 0 | mode < S_ACCESS_BIN
	then do;
		no_status_permission = "1"b;
		code = 0;
		call hcs_$get_user_effmode (file_path, FIRST_COMPONENT_NAME, "", current_validation_level, mode, code)
		     ;
		if code ^= 0 | mode < R_ACCESS_BIN
		then call ERROR_RETURN (error_table_$no_info);
	     end;

/**** The process has sufficient access to validate that this is a DM file.
      Do so by seeing if the first component has an add-name equal to the
      value of DM_FILE_VALIDATION_NAME and has a value for its bit count that
      is a valid encoding of the extended ring brackets of the file.
      Also check that the first (real) ring bracket number is equal to the
      ring of execution.  */

	call hcs_$status_minf (file_path, DM_FILE_VALIDATION_NAME, DONT_CHASE_LINK, type, bit_count, code);
	if code ^= 0
	then call ERROR_RETURN (error_table_$not_seg_type);

	call hcs_$get_ring_brackets (file_path, FIRST_COMPONENT_NAME, ring_brackets, code);
	if code ^= 0
	then call ERROR_RETURN (error_table_$not_seg_type);
	if ring_brackets (1) ^= current_validation_level
	then call ERROR_RETURN (error_table_$not_seg_type);

	if get_ring_brackets
	then do;
		extended_ring_brackets (WRITE_BRACKET) = divide (bit_count, 8, 3, 0);
		extended_ring_brackets (READ_BRACKET) = mod (bit_count, 8);
		if check_write
		then do;
			if caller_validation_level > extended_ring_brackets (WRITE_BRACKET)
			then if no_status_permission
			     then call ERROR_RETURN (error_table_$no_info);
			     else call ERROR_RETURN (error_table_$no_w_permission);
		     end;
		else if check_read
		then do;
			if caller_validation_level > extended_ring_brackets (READ_BRACKET)
			then if no_status_permission
			     then call ERROR_RETURN (error_table_$no_info);
			     else call ERROR_RETURN (error_table_$no_r_permission);
		     end;
		else p_ring_brackets = extended_ring_brackets;
	     end;

/**** Restore validation level before returning. */

	p_code = 0;
MAIN_RETURN:
	call cu_$level_set (caller_validation_level);

	return;
%page;
ERROR_RETURN:
     proc (er_p_code);
	dcl     er_p_code		 fixed bin (35);

	p_code = er_p_code;
	go to MAIN_RETURN;

     end ERROR_RETURN;

%page;
%include access_mode_values;
%page;
%include status_structures;
%page;
%include dm_file_validation_name;

     end fm_validate_;




		    get_dm_free_area_.pl1           04/09/85  1537.6r w 04/08/85  1128.1       68508



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

/* DESCRIPTION:
         This routine gets a pointer to the Data Management free area.
*/

/* HISTORY:
Written by Matthew Pierret, 02/23/83.
Modified:
03/29/83 by Lindsey Spratt:  Changed to create its own free area, rather than
	  reference dm_data_$area_ptr.  Added an entry, set, for setting the
	  dm_area_ptr to an arbitrary location.
04/05/83 by Lindsey L. Spratt:  Changed the $set entry to take two arguments,
            a directory pathname and an error code.  It creates a new segment
            in the specified directory and makes this the initial component of
            the dm_free_area.
12/07/84 by Matthew Pierret:  Moved main procedure statement to standard 
            location. Used local my_area_info instead of allocating one.
12/08/84 by Lindsey L. Spratt:  Fixed to my_area_info when setting
            internal_area_ptr, rather than area_info.
02/07/85 by Lindsey L. Spratt:  Changed the $set entry to take parameter
            specifying whether or not to release the old free area (if there
            is one), and removed the p_code argument.  Changed the area suffix
            to be gotten from the new internal proc GET_AREA_SUFFIX.  This is
            done in two places, the gap_area_info.owner value setting and the
            temp_area_entry name setting.  The new form of the is two
            components, the validation level followed by the value of
            AREA_NAME ("dm_free_area").  The setting of the area_ptr is now
            done by an internal proc, GET_AREA_PTR, which is used by both the
            main and $set entries.  $set is changed to use
            initiate_file_$create instead of hcs_$append_branchx and
            initiate_file_.  Error reporting is now done via ERROR_RETURN
            (which calls sub_err_), rather than via a "code" parameter.
*/

/* format: style2,ind3 */

get_dm_free_area_:
   proc () returns (ptr);

/* START OF DECLARATIONS */
/* Parameter */

      dcl	    p_temp_dir_path	       char (*) parm;
      dcl	    p_release_old_area     bit (1) aligned parm;
      dcl	    p_output_area_ptr      ptr parm;

/* Automatic */

      dcl	    seg_was_created	       bit (1) aligned init (NO);
      dcl	    temp_seg_ptr	       ptr init (null);
      dcl	    code		       fixed bin (35);
      dcl	    temp_area_dir	       char (256);
      dcl	    temp_area_entry	       char (64);

/* Based */
/* Builtin */

      dcl	    null		       builtin;

/* Constant */

      dcl	    AREA_NAME	       init ("dm_free_area") char (12) options (constant) internal static;
      dcl	    (
	    YES		       init ("1"b),
	    NO		       init ("0"b)
	    )		       bit (1) aligned internal static options (constant);
      dcl	    myname	       init ("get_dm_free_area_") char (32) varying internal static options (constant);

/* Entry */

      dcl	    absolute_pathname_     entry (char (*), char (*), fixed bin (35));
      dcl	    cu_$arg_count	       entry (fixed bin, fixed bin (35));
      dcl	    cu_$arg_list_ptr       entry (ptr);
      dcl	    cu_$arg_ptr	       entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
      dcl	    cu_$level_get	       entry (fixed bin);
      dcl	    define_area_	       entry (ptr, fixed bin (35));
      dcl	    hcs_$append_branch     entry (char (*), char (*), fixed bin (5), fixed bin (35));
      dcl	    initiate_file_$create  entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24),
			       fixed bin (35));
      dcl	    ioa_$general_rs	       entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned,
			       bit (1) aligned);
      dcl	    pathname_	       entry (char (*), char (*)) returns (char (168));
      dcl	    release_area_	       entry (ptr);
      dcl	    sub_err_	       entry () options (variable);
      dcl	    unique_chars_	       entry (bit (*)) returns (char (15));

/* External */

      dcl	    sys_info$max_seg_size  fixed bin (35) ext static;

/* Static */

      dcl	    internal_area_ptr      ptr init (null) internal static;

/* END OF DECLARATIONS */


      return (GET_AREA_PTR (null ()));

set:
   entry (p_temp_dir_path, p_release_old_area, p_output_area_ptr);
      code = 0;

      if internal_area_ptr ^= null & p_release_old_area = YES
      then call release_area_ (internal_area_ptr);

      temp_seg_ptr = null;

      call absolute_pathname_ (p_temp_dir_path, temp_area_dir, code);
      if code ^= 0
      then call ERROR_RETURN (code, "^/Unable to convert ""^a"" into an absolute path.", p_temp_dir_path);

      temp_area_entry = unique_chars_ ("0"b) || "." || GET_AREA_SUFFIX ();

      call initiate_file_$create (temp_area_dir, temp_area_entry, RW_ACCESS, temp_seg_ptr, seg_was_created, (0), code);
      if code ^= 0
      then call ERROR_RETURN (code, "^/Unable to create the new dm free area segment ""^a"".",
	      pathname_ (temp_area_dir, temp_area_entry));

      p_output_area_ptr = GET_AREA_PTR (temp_seg_ptr);

      return;


ERROR_RETURN:
   proc () options (variable);
      dcl	    er_p_code	       fixed bin (35) based (er_p_code_ptr);
      dcl	    er_p_code_ptr	       ptr init (null);
      dcl	    er_msg	       char (1024) varying aligned;

      dcl	    1 er_msg_struc	       aligned based (addr (er_msg)),
	      2 len	       fixed bin (21),
	      2 str	       char (length (er_msg)) unaligned;

      dcl	    er_arg_list_ptr	       ptr;
      dcl	    er_nargs	       fixed bin;

      call cu_$arg_list_ptr (er_arg_list_ptr);
      call cu_$arg_count (er_nargs, (0));
      call cu_$arg_ptr (1, er_p_code_ptr, (0), (0));
      if er_nargs > 1
      then call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_msg_struc.str, er_msg_struc.len, "0"b, "0"b);
      else er_msg = "";

      call sub_err_ (er_p_code, myname, ACTION_CANT_RESTART, null (), 0, "^a", er_msg);
   end ERROR_RETURN;
%page;
GET_AREA_PTR:
   proc (gap_p_initial_seg_ptr) returns (ptr);
      dcl	    gap_p_initial_seg_ptr  ptr parm;
      dcl	    1 gap_area_info	       aligned like area_info;
      dcl	    gap_code	       fixed bin (35) init (0);

      if internal_area_ptr = null () | gap_p_initial_seg_ptr ^= null ()
      then
         do;
	  gap_area_info.version = area_info_version_1;
	  gap_area_info.areap = gap_p_initial_seg_ptr;
	  gap_area_info.owner = GET_AREA_SUFFIX ();
	  gap_area_info.size = sys_info$max_seg_size;
	  string (gap_area_info.control) = "0"b;
	  gap_area_info.control.system = YES;		/* Makes extensions be created in the same directory as the original component. */
	  gap_area_info.control.extend = YES;
	  gap_area_info.control.zero_on_alloc = YES;

	  call define_area_ (addr (gap_area_info), gap_code);
	  if gap_code ^= 0
	  then call ERROR_RETURN (gap_code, "^/Unable to define the Data Management temporary area.");

	  internal_area_ptr = gap_area_info.areap;
         end;
      return (internal_area_ptr);
   end GET_AREA_PTR;
%page;
GET_AREA_SUFFIX:
   proc () returns (char (*));
      dcl	    gas_ring	       fixed bin init (0);
      dcl	    gas_ring_pic	       pic "9";
      call cu_$level_get (gas_ring);
      gas_ring_pic = gas_ring;
      return (gas_ring_pic || "." || AREA_NAME);
   end GET_AREA_SUFFIX;
%page;
%include access_mode_values;
%page;
%include area_info;
%page;
%include sub_err_flags;
   end get_dm_free_area_;




		    hc_dm_util_.pl1                 05/17/85  1650.9re  05/17/85  1328.5       75186



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

/* DESCRIPTION:
    Utility routines for Data Management Support

        set_journal_stamp - set the time stamp of a journal for Page Control

        allocate_journal_index - get ring-2 Data Management a free journal index

        free_journal_index - free a previously allocated journal index

        check_activate - determine whether a synchronized segment of a given size
             can be activated.

        activate - note activation of a synchronized segment of a given size.

        deactivate - note deactivation of a synchronized segment of a given size.
        get_journal_stamp - return current value of bj stamp.

        get_max_held_per_journal - return dm_journal.max_held_per_journal.

        get_n_journals - return dm_journal.n_journals

        validate_bj_uid - check supplied BJ uid against dm_journal_seg_ bj uid.
*/

/*  HISTORY:
Written by J. Bongiovanni, 10/15/82.
Modified:
11/15/82 by J. Bongiovanni: to run in user-ring for testing
03/01/83 by Lee A. Newcomb: to preserve the journal index
	  value passed to the free_journal entry.
11/29/84 by Stanford S. Cox: MAIN: Chg to use parm prefix. ER: Added.
05/14/85 by R. Michael Tague: Added $get_journal_stamp,
            $get_max_held_per_journal, $get_n_journals, and $validate_bj_uid.
*/

/* format: style3 */
hc_dm_util_$set_journal_stamp:
     proc (p_journal_idx, p_time_stamp, p_code);

/*  Parameter  */

dcl	p_code		fixed bin (35) parameter;	/* Standard Error Code */
dcl	p_journal_idx	fixed bin parameter;	/* Journal Index */
dcl	p_time_stamp	fixed bin (71) parameter;	/* New time stamp */
dcl	p_uid		bit (36) aligned;		/* Ring-2 Unique ID for Journal */

/*  Automatic  */

dcl	code		fixed bin (35);
dcl	local_journal_idx	fixed bin;
dcl	journal_loop_idx	fixed bin;
dcl	local_time_stamp	fixed bin (71);
dcl	local_uid		bit (36) aligned;
dcl	time_stamp	fixed bin (71);
dcl	validated		bit (1) aligned;

/*  Static  */

dcl	END_OF_TIME	fixed bin (71) int static options (constant)
			init (1111111111111111111111111111111111111111111111111111b);

/*  External  */

dcl	error_table_$bad_arg
			fixed bin (35) external;
dcl	error_table_$invalid_dm_journal_index
			fixed bin (35) external;
dcl	error_table_$no_journals_free
			fixed bin (35) external;

/*  Entry  */

dcl	get_authorization_	entry returns (bit (72) aligned);

/*  Builtin  */

dcl	(addr, clock, divide)
			builtin;

/*  Condition  */
%page;
/*  SET_JOURNAL_STAMP - sets the time stamp for a specified journal  */

	local_journal_idx = p_journal_idx;
	local_time_stamp = p_time_stamp;
	p_code = 0;


	dm_journal_segp = addr (dm_journal_seg_$);
	dm_journal.set_stamp_calls = dm_journal.set_stamp_calls + 1;

	if (local_journal_idx <= 0) | (local_journal_idx > dm_journal.n_journals)
	then call ERROR_RETURN (error_table_$invalid_dm_journal_index);

	dm_per_journalp = addr (dm_journal.per_journal (local_journal_idx));
	if dm_per_journal.uid = ""b
	then call ERROR_RETURN (error_table_$invalid_dm_journal_index);

	dm_per_journal.time_stamp = local_time_stamp;

MAIN_RETURN:
	return;

%page;
/*  ALLOCATE_JOURNAL_INDEX - give ring-2 an unused journal index  */

allocate_journal_index:
     entry (p_uid, p_journal_idx, p_code);


	p_code = 0;

	dm_journal_segp = addr (dm_journal_seg_$);
	dm_journal.allocate_calls = dm_journal.allocate_calls + 1;

	if p_uid = ""b
	then call ERROR_RETURN (error_table_$bad_arg);

	local_uid = p_uid;

	journal_loop_idx = 0;
	code = 0;

	if dm_journal.n_journals <= dm_journal.n_journals_inuse
	then do;
		p_journal_idx = journal_loop_idx;
		call ERROR_RETURN (error_table_$no_journals_free);
	     end;

	do journal_loop_idx = 1 to n_journals;
	     dm_per_journalp = addr (dm_journal.per_journal (journal_loop_idx));
	     if dm_per_journal.uid = ""b
	     then do;
		     dm_journal.n_journals_inuse = dm_journal.n_journals_inuse + 1;
		     dm_per_journal.time_stamp = clock ();
		     dm_per_journal.access_class = get_authorization_ ();
		     dm_per_journal.uid = local_uid;
		     call RECOMPUTE_THRESH;
		     p_journal_idx = journal_loop_idx;
		     goto MAIN_RETURN;
		end;
	end;

	call ERROR_RETURN (error_table_$no_journals_free);
%page;
/* ************************************************************************
   * get_journal_stamp - Returns the value of the journal stamp for a     *
   * given dm_journal_seg_ index.  An access class check is performed	    *
   * before the information is returned.			    *
   ************************************************************************ */

get_journal_stamp:
     entry (p_journal_idx) returns (fixed bin (71));

	time_stamp = 0;

	dm_journal_segp = addr (dm_journal_seg_$);
	if (p_journal_idx > 0) & (p_journal_idx <= dm_journal.n_journals)
	then do;
		dm_per_journalp = addr (dm_journal.per_journal (p_journal_idx));
		if dm_per_journal.uid ^= ""b
		then time_stamp = dm_per_journal.time_stamp;
	     end;
	return (time_stamp);
%page;
/* ************************************************************************
   * get_max_held_per_journal - Return the value of		    *
   * dm_journal.max_held_per_journal from dm_journal_seg_.		    *
   ************************************************************************ */

get_max_held_per_journal:
     entry () returns (fixed bin);

	return (addr (dm_journal_seg_$) -> dm_journal.max_held_per_journal);
%page;
/* ************************************************************************
   * get_n_journals - Return the value of dm_journal.get_n_journals from  *
   * dm_journal_seg_.					    *
   ************************************************************************ */

get_n_journals:
     entry () returns (fixed bin);

	return (addr (dm_journal_seg_$) -> dm_journal.n_journals);
%page;
/* ************************************************************************
   * validate_bj_uid - Given a dm_journal_seg_ index and BJ uid, this	    *
   * entry returns true if the supplied uid matches the uid indexed in    *
   * the dm_journal_seg_ and the caller has authorization to know this.   *
   ************************************************************************ */

validate_bj_uid:
     entry (p_uid, p_journal_idx) returns (bit (1) aligned);

	validated = "0"b;

	dm_journal_segp = addr (dm_journal_seg_$);
	if (p_journal_idx > 0) & (p_journal_idx <= dm_journal.n_journals)
	then do;
		dm_per_journalp = addr (dm_journal.per_journal (p_journal_idx));
		if p_uid ^= ""b & p_uid = dm_per_journal.uid
		then validated = "1"b;
	     end;
	return (validated);
%page;
/*  FREE_JOURNAL_INDEX - frees a previously allocated journal index  */

free_journal_index:
     entry (p_journal_idx, p_code);



	p_code = 0;

	dm_journal_segp = addr (dm_journal_seg_$);
	dm_journal.free_calls = dm_journal.free_calls + 1;

	code = 0;


	local_journal_idx = p_journal_idx;

	if (local_journal_idx <= 0) | (local_journal_idx > dm_journal.n_journals)
	then call ERROR_RETURN (error_table_$invalid_dm_journal_index);

	dm_per_journalp = addr (dm_journal.per_journal (local_journal_idx));
	if dm_per_journal.access_class ^= get_authorization_ () | dm_per_journal.uid = ""b
	then call ERROR_RETURN (error_table_$invalid_dm_journal_index);

	dm_per_journal.time_stamp = END_OF_TIME;
	dm_per_journal.uid = ""b;
	dm_per_journal.access_class = ""b;


	dm_journal.n_journals_inuse = dm_journal.n_journals_inuse - 1;
	call RECOMPUTE_THRESH;
	goto MAIN_RETURN;
%page;
/*  RECOMPUTE_THRESH - Internal Procedure to recompute max held pages per
    journal, which is used by ring-2 Data Management to prevent flooding
    the system with held pages. */

RECOMPUTE_THRESH:
     proc;

	if dm_journal.n_journals_inuse = 0
	then dm_journal.max_held_per_journal = dm_journal.max_held_pages_mem;
	else dm_journal.max_held_per_journal = divide (dm_journal.max_held_pages_mem, dm_journal.n_journals_inuse, 17);

     end RECOMPUTE_THRESH;
%page;
ERROR_RETURN:
     proc (er_code);

dcl	er_code		fixed bin (35) parameter;

	p_code = er_code;
	goto MAIN_RETURN;
     end ERROR_RETURN;
%page;
%include dm_journal_seg_;

     end hc_dm_util_$set_journal_stamp;




		    lm_data_.cds                    01/04/85  0952.6re  01/03/85  1151.1       19638



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* Description:
   Lock manager per_process definitions */

/* HISTORY:

Written by BIM, 0483.
Modified:
830426 added trace_ switch 
830506 BIM added ev_channel so we wouldn't create one per txn. 
841018 SSC added lock_list_meters_ptr
*/

/* format: style3,idind30 */
lm_data_:
     procedure;

/*  Automatic  */

dcl	code			fixed bin (35);
dcl	1 local_cds_args		aligned like cds_args;

dcl	1 lock_data		aligned,
	  2 current_txn_id		bit (36) aligned init (""b),
	  2 txn_table_ptr             pointer init (null ()),
	  2 lock_seg_ptr		pointer init (null ()),
	  2 lock_segments_ptr	pointer init (null ()),
	  2 n_lock_segments		fixed bin init (0),
	  2 lock_per_process_ptr	pointer init (null ()),
	  2 fast_lock_data_ptr        pointer init (null ()),
	  2 lock_list_meters_ptr	pointer init (null ()),
	  2 trace 		bit (1) aligned init ("0"b),
	  2 ev_channel		fixed bin (71) aligned init (0);

/*  Static  */

dcl	EXCLUDE_ARRAY		(1) char (32) int static options (constant) init ("pad*");
dcl	MYNAME			char (15) int static options (constant) init ("lm_data_");

/*  Entry  */

dcl	com_err_			entry options (variable);
dcl	create_data_segment_	entry (ptr, fixed bin (35));

/*  Builtin  */

dcl	addr			builtin;
dcl	hbound			builtin;
dcl	null			builtin;
dcl	size			builtin;
dcl	unspec			builtin;
%page;

	unspec (local_cds_args) = ""b;

	local_cds_args.sections (2).p = addr (lock_data);
	local_cds_args.sections (2).len = size (lock_data);
	local_cds_args.sections (2).struct_name = "lock_data";
	local_cds_args.seg_name = MYNAME;
	local_cds_args.exclude_array_ptr = addr (EXCLUDE_ARRAY);
	local_cds_args.num_exclude_names = hbound (EXCLUDE_ARRAY, 1);
	local_cds_args.switches.have_static = "1"b;

	call create_data_segment_ (addr (local_cds_args), code);
	if code ^= 0
	then call com_err_ (code, MYNAME);

	return;
%page;
%include cds_args;

     end lm_data_;




		    lm_fast_lock_list_.alm          04/24/85  1016.3re  04/24/85  0803.2       36819



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lm_fast_lock_list_
"
"	Program to maintain linked lists of lock structures in a lockless
"	manner.
"
"	Entries:
"
"	thread_out_first	-  gets first block from a list
"	thread_in		-  threads a block into a list
"
"	Written by J. Bongiovanni, 06/15/82.
"	Modified:
"	05/16/85 by S. Cox: To correctly check if a null meter_ptr is given,
"	         and to not meter threadouts if at end of list.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	name	lm_fast_lock_list_
	entry	thread_out_first
	entry	thread_in


	even
NULL_PTR:	its	-1,1
SEGNO_OFFSET_MASK:
	vfd	o18/077777,o18/000077,o18/777777,18/077077

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lm_fast_lock_list_$thread_out_first
"
"	call lm_fast_lock_list_$thread_out_first (head_ptr, list_seg_ptr, meter_ptr, block_ptr)
"
"	   head_ptr -> structure describing head of list        (INPUT)
"	   list_seg_ptr -> somehwere in segment containing list (INPUT)
"	   meter_ptr -> area for metering data, or null         (INPUT)
"	   block_ptr -> block threaded out, or null             (OUTPUT)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

thread_out_first:
	eppab	ap|2,*			" ab -> ptr -> lm_fast_lock_list_head
	eppab	ab|0,*			" ab -> lm_fast_lock_list_head
	eppbb	ap|4,*			" bb -> ptr -> list segment
	epbpbb	bb|0,*			" bb -> base of list segment
	eppbp	ap|6,*			" bp -> ptr -> lm_fast_lock_list_meters
	eppbp	bp|0,*			" bp -> lm_fast_lock_list_meters

	epplb	NULL_PTR,*		" Set list empty
	ldq	ab|lock_list_head.firstp	" QU = Offset of first
	tze	thread_out_returns		" if end of list then quit and don't meter

	eax0	0			" Set not to do metering
	ldaq	ap|6,*
	eraq	NULL_PTR			" Null ptr supplied for metering
	anaq	SEGNO_OFFSET_MASK
	tze	thread_out_loop		" No
	eax0	1
	aos	bp|lock_list_meters.thrdout_calls

thread_out_loop:
	eax0	0,x0			" Metering?
	tze	thread_out_try		" No
	aos	bp|lock_list_meters.thrdout_steps

thread_out_try:
	ldq	ab|lock_list_head.firstp	" QU = Offset of first
	tze	thread_out_returns
	lda	bb|lock_list_block.nextp,qu	" AU = Offset of next
	stacq	ab|lock_list_head.firstp	" Make next first
	tnz	thread_out_loop		" Lost race
	epplb	bb|0,qu			" lb -> block

thread_out_returns:
	sprilb	ap|8,*			" blockp or null
	short_return

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lm_fast_lock_list_$thread_in
"
"	call lm_fast_lock_list_$thread_in (head_ptr, meter_ptr, block_ptr)
"
"	   head_ptr -> structure describing head of list (INPUT)
"	   meter_ptr -> area for metering data, or null  (INPUT)
"	   block_ptr -> block to thread in	         (INPUT)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

thread_in:
	eppab	ap|2,*			" ab -> ptr -> lm_fast_lock_list_head
	eppab	ab|0,*			" ab -> lm_fast_lock_list_head
	eppbp	ap|4,*			" bp -> ptr -> lm_fast_lock_list_meters
	eppbp	bp|0,*			" bp -> lm_fast_lock_list_meters
	epplb	ap|6,*			" lb -> ptr -> lm_fast_lock_list_block
	epplb	lb|0,*			" lb -> lm_fast_lock_list_block
	epbpbb	lb|0			" bb -> base of list segment

	eax0	0			" Set not to do metering
	ldaq	ap|4,*
	eraq	NULL_PTR			" Null ptr supplied for metering
	anaq	SEGNO_OFFSET_MASK
	tze	thread_in_loop		" No
	eax0	1
	aos	bp|lock_list_meters.thrdin_calls

thread_in_loop:
	eax0	0,x0			" Metering?
	tze	thread_in_try		" No
	aos	bp|lock_list_meters.thrdin_steps

thread_in_try:
	ldq	ab|lock_list_head.firstp	" QU = Offset of first
	stq	lb|lock_list_block.nextp	" Make first next
	eaa	lb|0			" And block first
	stacq	ab|lock_list_head.firstp	" Lockless
	tnz	thread_in_loop		" Lost race

	short_return

"
	include	dm_lock_list_strucs

	end




		    lm_init_fast_lock_data_.pl1     01/04/85  0952.6re  01/03/85  1151.2       28665



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

/*  DESCRIPTION:
   Program to initialize the per-system table used for fast locks.
   This should be called once per-bootload, before any fast lock is
   used by anybody.
*/

/* HISTORY:

   Written by J. Bongiovanni, 06/15/82.
   Modified:
   08/06/83 by Lee A. Newcomb:  removed obsolete code args. from calls
   to dm_per_system_ entries.
   10/10/84 by Stanford S. Cox:  For DM program standards, and to meter fast
   locks.
*/
/* format: style3,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,indcom,ind3 */
%page;
     /* format: style3 */
lm_init_fast_lock_data_:
     proc (p_code);

/*  Parameter  */

dcl	p_code		fixed bin (35) parameter;	/* Status code */

/*  Automatic  */

dcl	fast_lock_data_size fixed bin (18);
dcl	listx		fixed bin;

/*  Static  */

dcl	FAST_LOCK_DATA_SIZE fixed bin (18) int static options (constant) init (2048);

/*  External  */

dcl	dm_system_data_$fast_lock_data_rel
			bit (18) aligned external;
dcl	dm_system_data_$lock_list_meters_rel
			bit (18) aligned external;
dcl	dm_system_data_$meter_fast_locks
			bit (1) aligned external;

/*  Entry  */

dcl	dm_per_system_$alloc
			entry (fixed bin (18), ptr);
dcl	lm_fast_lock_list_$thread_in
			entry (ptr, ptr, ptr);

/*  Builtin  */

dcl	addr		builtin;
dcl	addrel		builtin;
dcl	bin		builtin;
dcl	divide		builtin;
dcl	null		builtin;
dcl	rel		builtin;
dcl	size		builtin;
dcl	unspec		builtin;

%page;

	p_code = 0;
	call dm_per_system_$alloc (FAST_LOCK_DATA_SIZE, fast_lock_data_ptr);

	dm_system_data_$fast_lock_data_rel = rel (fast_lock_data_ptr);

	unspec (fast_lock_data) = ""b;
	fast_lock_data.version = FAST_LOCK_DATA_VERSION_1;
	fast_lock_data.size = FAST_LOCK_DATA_SIZE;

	lock_list_block_words = size (fast_lock_wakeup_block);
	fast_lock_data.n_list_entries =
	     divide (fast_lock_data.size - (bin (rel (addr (fast_lock_data.list))) - bin (rel (addr (fast_lock_data)))),
	     size (lock_list_block), 17);

	lock_list_block_ptr = addr (fast_lock_data.list);
	do listx = 1 to fast_lock_data.n_list_entries;
	     lock_list_block.nextp, lock_list_block.mbz = ""b;
	     lock_list_block.block_words = lock_list_block_words;
	     unspec (lock_list_block.block_data) = ""b;
	     call lm_fast_lock_list_$thread_in (addr (fast_lock_data.free_list_head), null (), lock_list_block_ptr);
	     lock_list_block_ptr = addrel (lock_list_block_ptr, size (lock_list_block));
	end;

	if dm_system_data_$meter_fast_locks
	then do;					/* setup fast lock meters */
		call dm_per_system_$alloc (size (lock_list_meters), lock_list_meters_ptr);
		unspec (lock_list_meters) = "0"b;
		lock_list_meters.version = LOCK_LIST_METERS_VERSION_1;
		dm_system_data_$lock_list_meters_rel = rel (lock_list_meters_ptr);
	     end;
	else dm_system_data_$lock_list_meters_rel = "0"b;

%page;
%include dm_fast_lock_strucs;
%include dm_lock_list_strucs;

     end lm_init_fast_lock_data_;




		    lm_per_system_init_.pl1         01/04/85  0952.6re  01/03/85  1151.2       46044



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

/*  DESCRIPTION:
    Per-System Initialization Program for Locking
*/

/* HISTORY:

Written by J. Bongiovanni, 01/15/82.
Modified:
12/15/82 by J. Bongiovanni: for multi-segment lock table.
03/31/83 by BIM: Renamed, made per-transaction, fast lock included.
08/06/83 by Lee A. Newcomb: removed obsolete code args. from calls
	  to dm_per_system_ entries.
11/30/83 by L. A. Newcomb:  Added NORMAL_LOCK_SEG_SIZE temporarily until the
            lock seg size can be integrated into the configuration file.
05/01/84 by R. Michael Tague:  Split dm_lm_meters structure from
            dm_lm_system_data, added %include dm_lm_meters.
10/17/84 by Stanford S. Cox:  For DM program standards, and to allow quit,
            alrm, and cput ips when testing.
*/
/* format: style3 */
lm_per_system_init_:
     proc (p_code);

/*  Parameter  */

dcl	p_code		fixed bin (35) parameter;	/* Standard error code */

/*  Automatic  */

dcl	freex		fixed bin;
dcl	hashx		fixed bin;

/*  Static  */

dcl	HASH_TABLE_ENTRIES	fixed bin int static options (constant) init (256);
dcl	HASH_MASK		bit (36) aligned int static options (constant) init ("000000000377"b3);
dcl	IPS_NAMES		(3) char (32) int static options (constant) init ("quit", "alrm", "cput");
dcl	MAX_LOCK_SEGMENTS	fixed bin int static options (constant) init (100);

/* The next two should be eliminated in favor of a config file parameter. */
dcl	TEST_LOCK_SEG_SIZE	fixed bin (19) int static options (constant) init (1024 * 4);
						/* use 4K seg. */
dcl	NORMAL_LOCK_SEG_SIZE
			fixed bin (19) int static options (constant) init (1024 * 16);
						/* use 16K seg. */

/*  External  */

dcl	dm_system_data_$lock_ips_mask
			bit (36) aligned external;
dcl	dm_system_data_$max_n_transactions
			fixed bin external;
dcl	sys_info$data_management_ringno
			fixed bin external;
dcl	sys_info$max_seg_size
			fixed bin (19) external;

/*  Entry  */

dcl	lm_init_fast_lock_data_
			entry (fixed bin (35));
dcl	create_ips_mask_	entry (ptr, fixed bin, bit (36) aligned);
dcl	dm_per_system_$create
			entry (char (*), ptr);
dcl	get_ring_		entry () returns (fixed bin (3));
dcl	sub_err_		entry () options (variable);

/*  Builtin  */

dcl	addr		builtin;
dcl	divide		builtin;
dcl	fixed		builtin;
dcl	hbound		builtin;
dcl	size		builtin;
dcl	wordno		builtin;

dcl	ME		char (32) init ("lm_per_system_init_") int static options (constant);

	p_code = 0;
	call lm_init_fast_lock_data_ (p_code);
	if p_code ^= 0
	then return;

	lock_segno = 1;
	call dm_per_system_$create (LOCK_SEGNAME || lock_segno, lock_seg_ptr);
	lock_seg.version = LOCK_SEG_VERSION_1;
	lock_seg.n_transaction_table_entries = dm_system_data_$max_n_transactions;

	lock_seg.lock = 0;

/*  If we're in test mode, set the segment size small so we get lots of them.  */

	if get_ring_ () = sys_info$data_management_ringno
	then do;
		lock_seg.lock_seg_size = NORMAL_LOCK_SEG_SIZE;
		dm_system_data_$lock_ips_mask = "0"b;
	     end;
	else do;
		lock_seg.lock_seg_size = TEST_LOCK_SEG_SIZE;
		call create_ips_mask_ (addr (IPS_NAMES), hbound (IPS_NAMES, 1), dm_system_data_$lock_ips_mask);
	     end;

	lock_seg.n_hash_table_entries = HASH_TABLE_ENTRIES;
	lock_seg.hash_mask = HASH_MASK;
	lock_seg.meters.version = LOCK_METERS_VERSION_1;

	lock_seg.transaction_table_offset = wordno (addr (lock_seg.transaction_table));
	lock_seg.hash_table_offset = wordno (addr (lock_seg.hash_table));

	lock_hash_table_ptr = addr (lock_seg.hash_table);
	do hashx = 1 to lock_seg.n_hash_table_entries;
	     lock_hash_table.buckets (hashx) = NULL_VPTR;
	end;

	lock_block_array_ptr = addr (lock_seg.free);
	n_lock_blocks = divide (lock_seg.lock_seg_size - fixed (wordno (lock_block_array_ptr)), size (lock_block), 17);
	lock_seg.free_list_ptr = VPTR (lock_block_array_ptr);
	lock_free_block_ptr = addr (lock_block_array (1));
	do freex = 1 to n_lock_blocks;
	     lock_free_block.free_fp = VPTR (addr (lock_block_array (freex)));
	     lock_free_block_ptr = addr (lock_block_array (freex));
	     lock_free_block.seg_inx = 1;
	     lock_free_block.type = TYPE_FREE;
	end;
	lock_free_block.free_fp = NULL_VPTR;

	lock_seg.n_lock_blocks = n_lock_blocks;
	lock_seg.lock_array_offset = wordno (lock_block_array_ptr);
	lock_seg.n_lock_segments = 1;
	lock_seg.max_lock_segments = MAX_LOCK_SEGMENTS;

	return;
%page;
/*  Internal Procedure to create a lock virtual pointer to an object in
    this segment. */

VPTR:
     proc (vptr_p_lock_ptr) returns (1 like lock_virtual_ptr);

dcl	vptr_p_lock_ptr	ptr parameter;

dcl	1 vptr_lock_virtual_ptr
			aligned like lock_virtual_ptr;

	vptr_lock_virtual_ptr.seg_inx = 1;
	vptr_lock_virtual_ptr.offset = wordno (vptr_p_lock_ptr);
	return (vptr_lock_virtual_ptr);

     end VPTR;
%page;
%include dm_lm_system_data;
%include dm_lm_meters;
%include sub_err_flags;
     end lm_per_system_init_;




		    lock_manager_.alm               04/24/85  1016.3re  04/24/85  0803.3       55458



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
"
"	The transfer vector for the Data Management Lock Manager.
"
"	Simple cases of lock_fast and unlock_fast are handled
"    in this transfer vector.
"
"	NOTE -- Externally available entries go through a gate
"    or the inner ring tv, to make sure the firstref runs.  Entries
"    internal to the lock manager tra directly.
"
"
" HISTORY:
"
" Written by J. Bongiovanni, 06/01/82.
" Modified:
" 03/01/83 by Jeffrey D. Ives:  to call lm_gate_.
" 04/19/83 by Jeffrey D. Ives:  changed from tra to call6 so that gates work.
" 04/29/83 by BIM:  changed to not bother with the gate for entries that
"	    are not available outside DM ring, which is most.
" 05/09/83 by BIM:  changed not to use call6 when tra will do.
" 07/29/83 by Lindsey Spratt: Changed lock_lock_data and unlock_lock_data
"	    to reference lm_inner_ring_tv_ rather than lm_per_system_
"	    directly.  Also, changed to reference
"	    lm_inner_ring_tv_$lock_fast rather than lm_fast_lock_
"	    directly.  This both makes the setup of this tv more
"	    consistent and makes the separation of the lock_manager_ tv
"	    from the bound object containing the lm_inner_ring_tv_
"	    easier.
" 01/03/84 by Lee A. Newcomb:  changed to use privileged and administrative
"	    gates where necessary, which is curr. all gates references.
" 05/02/84 by Lee A. Newcomb:  added user_shutdown entry.
" 10/05/84 by Stanford S. Cox: changed init_per_system to use tra.
" 11/22/84 by Lee A. Newcomb:  Added $per_process_init entry.
" 12/02/84 by Stanford S. Cox: Chg *inner_ring_tv_ to be =firstref_tv_
" 01/09/85 by Lindsey Spratt: Changed to use dm_fast_lock_alm_strucs instead
"	    of dm_fast_lock_strucs.
" 02/14/85 by Stanford S. Cox: Chg (lock unlock)_fast to guarantee eligibility.
" 03/25/85 by Stanford S. Cox:  Added copy_fast_data
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	lock_manager_


	macro	gate_transfer
	segdef	&1
&1:
	getlp
	call6	&2
&end
	macro	transfer
	segdef	&1
&1:	getlp
	tra	&2
&end


	transfer		checkpoint,lm_firstref_tv_$checkpoint
	gate_transfer	copy_data,dm_admin_gate_$lm_copy_data
	gate_transfer	copy_fast_data,dm_admin_gate_$lm_copy_fast_data
	transfer		init_per_system,lm_per_system_init_$lm_per_system_init_
	transfer		lock,lm_firstref_tv_$lock
	transfer		lock_lock_data,lm_firstref_tv_$lock_lock_data
	transfer		per_process_init,lm_firstref_tv_$per_process_init
	gate_transfer	reset_system_meters,dm_admin_gate_$lm_reset_system_meters
	transfer		resolve_deadlock,lm_firstref_tv_$resolve_deadlock
	gate_transfer	system_segment_count,dm_admin_gate_$lm_system_segment_count
	transfer		unlock,lm_firstref_tv_$unlock
	transfer		unlock_all,lm_firstref_tv_$unlock_all
	transfer		unlock_lock_data,lm_firstref_tv_$unlock_lock_data
	transfer		unlock_to_checkpoint,lm_firstref_tv_$unlock_to_checkpoint
	transfer		user_shutdown,lm_firstref_tv_$user_shutdown
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lock_fast
"
"	call lock_manager_$lock_fast (addr (lock_double_word), timeout_i, code_o)
"
"	Tries to lock with stac instruction.  Calls inner ring if stac fails.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	lock_fast
lock_fast:
	getlp
	epp2	pr0|2,*			" pr2 -> lock word ptr
	epp2	pr2|0,*			" pr2 -> lock

	lda	pr4|process_id		" Get my process id.
	stac	pr2|fast_lock.lock_word	" If stac doesn't work,
	tnz	LF_CHECK_MYLOCK		" then check for mylock.


	stz	pr0|6,*			" Else set code_o = 0.
	call6	<dm_hcs_>|[guaranteed_eligibility_on]
" 	dm_hcs_ returns via return_ptr in lock_manager_ caller's stack frame
"	short_return			" That was easy.


LF_CHECK_MYLOCK:
	cmpa	pr2|fast_lock.lock_word	" If locked to this process
	tze	LF_MYLOCK_ERROR		" then warn the caller.

	tra	lm_firstref_tv_$lock_fast	" Else call inner ring.
	

LF_MYLOCK_ERROR:
	lda	dm_error_$fast_lock_mylock
	sta	pr0|6,*			" Return the error
	short_return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	unlock_fast
"
"	call lock_manager_$unlock_fast (addr (lock_double_word), code_o)
"
"	Tries to unlock lock. Calls inner ring if notify switch set.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	segdef	unlock_fast
unlock_fast:
	getlp
	epp2	pr0|2,*			" pr2 -> lock word ptr
	epp2	pr2|0,*			" pr2 -> lock

	lda	0,dl
	ldq	pr4|process_id		" Get my process id.
	stacq	pr2|fast_lock.lock_word	" Try to unlock
	tnz	UF_NOT_LOCKED

	lda	fast_lock.notify_sw,du
	cana	pr2|fast_lock.notify_sw_word	" Somebody wants notify?
	tnz	UF_RESET_NOTIFY_SW

	stz	pr0|4,*
	call6	<dm_hcs_>|[guaranteed_eligibility_off]
" 	dm_hcs_ returns via return_ptr in lock_manager_ caller's stack frame
"	short_return


UF_NOT_LOCKED:
	lda	dm_error_$fast_lock_not_locked
	sta	pr0|4,*			" Return error
	short_return


UF_RESET_NOTIFY_SW:
	era	=-1			" Reset notify switch.
	ansa	pr2|fast_lock.notify_sw_word

	tra	lm_firstref_tv_$notify_unlock	
"	PL/I does the rest, including calling dm_hcs_$guaranteed_eligibility_off
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	get_process_id
"
"	firstref	<*text>|get_process_id
"
"	This is the first reference trap procedure.
"	It gets the process id into the linkage section.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


get_process_id:
	getlp
	push

	ldaq	=v18/2,18/4,18/0,18/0
	staq	arg_list
	epp2	pr4|process_id
	spri2	arg_list+2

	call	get_process_id_$get_process_id_(arg_list)

	return

	firstref	<*text>|get_process_id



" AUTOMATIC  AUTOMATIC  AUTOMATIC  AUTOMATIC  AUTOMATIC  AUTOMATIC  AUTOMATIC

	tempd	arg_list(2)


" LINKAGE  LINKAGE  LINKAGE  LINKAGE  LINKAGE  LINKAGE  LINKAGE  LINKAGE

	use	linkage_section

process_id:
	oct	0

	join	/link/linkage_section
"
	include	dm_fast_lock_alm_strucs

	end




		    print_data_.pl1                 08/20/86  1427.3rew 08/19/86  1422.6      159435



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

/* DESCRIPTION:

   This program is for printing p_stuff, a string produced by a "put data",
   in a special format.  print_data_info, based on print_data_info_ptr, is
   used to control the format, as well as select the output switch.
*/
/* HISTORY:

   Written by Lindsey L. Spratt.
   Modified:
   06/21/79 by Lindsey Spratt; add rtrim(ltrim()) of intervals, check for
   correct print_data_info version, add error code reporting.
   10/29/83 by Benson I. Margulies: for $rs, .hex
*/


/****^  HISTORY COMMENTS:
  1) change(86-06-18,Kissel), approve(86-07-31,MCR7468), audit(86-07-31,Wong),
     install(86-08-19,MR12.0-1133):
     Changed to better handle the printing of array values.
                                                   END HISTORY COMMENTS */


/* format: style2,idind30,indcomtxt */

print_data_:
     proc (p_stuff, print_data_info_ptr, p_code);

/* Automatic */

	dcl     idx		        fixed bin;
	dcl     start_scan_idx	        fixed bin (24);
	dcl     scan_length		        fixed bin (24);
	dcl     code		        fixed bin (35);
	dcl     p_code		        fixed bin (35);
	dcl     more_intervals	        bit (1);
	dcl     first_interval	        bit (1);

	dcl     array_id		        char (256) varying;
	dcl     first_storage_id	        char (256) varying;
	dcl     previous_storage_id	        char (256) varying;
	dcl     storage_id_before_pad	        char (256) varying;
	dcl     first_array_id	        char (256) varying;
	dcl     first_value		        char (1024) varying;
	dcl     array_elem_no	        fixed bin;
	dcl     left_par_idx	        fixed bin;

	dcl     1 item,
		2 storage_id	        char (256) varying,
		2 value		        char (1024) varying;
	dcl     storage_id_pad	        char (256) varying;
	dcl     interval_spec	        char (256) varying;
	dcl     first_blank		        fixed bin (35);
	dcl     temp_seg_ptrs	        (2) ptr;
	dcl     target_ptr		        ptr;
	dcl     source_ptr		        ptr;
	dcl     current_period	        fixed bin (35);
	dcl     current_quote	        fixed bin (35);
	dcl     following_quote	        fixed bin (35);
	dcl     following_double_quote        fixed bin (35);
	dcl     temp_value		        char (32) varying;
	dcl     more		        bit (1);
	dcl     null		        builtin;
	dcl     found		        bit (1);
	dcl     level		        fixed bin;
	dcl     root_of_level_list	        ptr;
	dcl     p_stuff		        char (*) varying;
	dcl     p_return_string	        char (*) varying;
	dcl     rs_entry		        bit (1) aligned;

/* Based */

	dcl     temp_seg		        char (sys_info$max_seg_size * 4) varying based;

/* External */

	dcl     sys_info$max_seg_size	        fixed bin (35) ext;
	dcl     error_table_$unimplemented_version
				        fixed bin (35) ext;

/* Entry */

	dcl     ioa_$rsnnl		        entry options (variable);
	dcl     get_temp_segments_	        entry (char (*), pointer dimension (*), fixed bin (35));
	dcl     release_temp_segments_        entry (char (*), pointer dimension (*), fixed bin (35));

	dcl     index		        builtin;
	dcl     substr		        builtin;


	rs_entry = "0"b;
	go to COMMON;

rs:
     entry (p_stuff, print_data_info_ptr, p_return_string, p_code);

	rs_entry = "1"b;
	p_return_string = "";

COMMON:
	if print_data_info.version ^= print_data_info_version_1
	then do;
		p_code = error_table_$unimplemented_version;
		return;
	     end;
	call get_temp_segments_ ("print_data", temp_seg_ptrs, code);
	source_ptr = temp_seg_ptrs (1);
	target_ptr = temp_seg_ptrs (2);
	source_ptr -> temp_seg = p_stuff;
	target_ptr -> temp_seg = "";

	array_id = "";
	first_storage_id = "";
	previous_storage_id = "";
	storage_id_before_pad = "";
	first_array_id = "";
	first_value = "";
	array_elem_no = 0;


	more_intervals = "1"b;
	interval_spec = rtrim (ltrim (print_data_info.intervals));
	start_scan_idx = 1;
	call setup_interval (start_scan_idx);
	first_interval = "1"b;
	do while (more_intervals | first_interval);
	     first_interval = "0"b;			/* The following loop parses a storage_id and a value out of p_stuff.
						   first_blank identifies the end of the storage_id which begins p_stuff. */

	     first_blank = index (source_ptr -> temp_seg, "=");
	     root_of_level_list = null;
	     do while (first_blank > 0);
		item.storage_id = substr (source_ptr -> temp_seg, 1, first_blank);
						/* p_stuff is set up to begin with the storage_id. */
		current_period = index (item.storage_id, ".");
						/* The storage id is indented two spaces for each level in the id. */
		storage_id_pad = "";
		do level = 1 by 1 while (current_period > 0);
		     temp_value = substr (item.storage_id, 1, current_period - 1);
		     call check_level (temp_value, level, found);
		     item.storage_id = substr (item.storage_id, current_period + 1);
		     if ^found
		     then do;
			     temp_value = storage_id_pad || temp_value;

			     if array_elem_no = 0
			     then call output ("^a", temp_value);
			     else do;
				     if array_elem_no = 1
				     then do;
					     call output ("^a^vt^a", first_storage_id,
						print_data_info.value_column, first_value);
					end;
				     else do;
					     first_storage_id =
						substr (first_storage_id, 1, length (first_storage_id) - 1);
					     call output ("^a thru ^a^vt^a", first_storage_id,
						ltrim (previous_storage_id), print_data_info.value_column,
						first_value);

					end;
				     call output ("^a", temp_value);
				     array_elem_no = 0;
				end;
			end;

		     storage_id_pad = copy (" ", print_data_info.indentation) || storage_id_pad;
		     current_period = index (item.storage_id, ".");
		end;
		call check_level (item.storage_id, level, found);
		storage_id_before_pad = item.storage_id;
		item.storage_id = storage_id_pad || item.storage_id;
		target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, first_blank + 1));
		call switch_source_and_target;	/*  The string is processed for quotes, and quote doubling.  */

		if substr (source_ptr -> temp_seg, 1, 1) = """"
		then do;
			current_quote = 1;
			more = "1"b;
			do while (more);
			     following_quote =
				index (substr (source_ptr -> temp_seg, current_quote + 1), """") + current_quote;
			     following_double_quote =
				index (substr (source_ptr -> temp_seg, current_quote + 1), """""")
				+ current_quote;
			     if following_double_quote = current_quote | following_quote < following_double_quote
			     then more = "0"b;
			     else current_quote = following_quote;
			end;
			item.value = substr (source_ptr -> temp_seg, 1, following_quote);
			source_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, following_quote + 1));

			if index (source_ptr -> temp_seg, "b") = 1
			then do;			/*  Allow for bit strings. */
				item.value = item.value || "b";
				if print_data_info.flags.octal & (mod (length (item.value) - 3, 3) = 0)
				then do;
					call ioa_$rsnnl ("^oo", item.value, (0),
					     bin (
					     bit (substr (item.value, 2, length (item.value) - 3),
					     length (item.value) - 3)));
				     end;
				else if print_data_info.flags.hex & (mod (length (item.value) - 3, 4) = 0)
				then do;
					call ioa_$rsnnl ("^.4bx", item.value, (0),
					     bit (substr (item.value, 2, length (item.value) - 3),
					     length (item.value) - 3));
				     end;

				target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, 2));
				call switch_source_and_target;
			     end;
		     end;
		else do;
			first_blank = index (source_ptr -> temp_seg, " ");
			if first_blank = 0
			then first_blank = length (source_ptr -> temp_seg);
			item.value = substr (source_ptr -> temp_seg, 1, first_blank);
			target_ptr -> temp_seg = ltrim (substr (source_ptr -> temp_seg, first_blank));
			call switch_source_and_target;
		     end;

		left_par_idx = index (storage_id_before_pad, "(");
		if left_par_idx ^= 0
		then do;
			array_id = substr (storage_id_before_pad, 1, left_par_idx);
			if array_elem_no = 0
			then do;
				first_array_id = array_id;
				first_storage_id = item.storage_id;
				first_value = item.value;
				array_elem_no = 1;
			     end;
			else do;
				if array_id = first_array_id & item.value = first_value
				then do;
					array_elem_no = array_elem_no + 1;
					previous_storage_id = item.storage_id;
				     end;
				else do;
					if array_elem_no = 1
					then do;
						call output ("^a^vt^a", first_storage_id,
						     print_data_info.value_column, first_value);
					     end;
					else do;
						first_storage_id =
						     substr (first_storage_id, 1,
						     length (first_storage_id) - 1);
						call output ("^a thru ^a^vt^a", first_storage_id,
						     ltrim (previous_storage_id),
						     print_data_info.value_column, first_value);
					     end;
					first_array_id = array_id;
					first_storage_id = item.storage_id;
					first_value = item.value;
					array_elem_no = 1;
				     end;

			     end;

		     end;

		else do;
			if array_elem_no = 0
			then call output ("^a^vt^a", item.storage_id, print_data_info.value_column, item.value);
			else do;
				if array_elem_no = 1
				then do;
					call output ("^a^vt^a", first_storage_id, print_data_info.value_column,
					     first_value);
				     end;
				else do;
					first_storage_id =
					     substr (first_storage_id, 1, length (first_storage_id) - 1);
					call output ("^a thru ^a^vt^a", first_storage_id,
					     ltrim (previous_storage_id), print_data_info.value_column,
					     first_value);

				     end;
				call output ("^a^vt^a", item.storage_id, print_data_info.value_column, item.value)
				     ;
				array_elem_no = 0;
			     end;
		     end;

		first_blank = index (source_ptr -> temp_seg, "=");
	     end;
	     call setup_interval (start_scan_idx);
	end;

	if array_elem_no ^= 0
	then do;

		if array_elem_no = 1
		then call output ("^a^vt^a", first_storage_id, print_data_info.value_column, first_value);

		else do;
			first_storage_id = substr (first_storage_id, 1, length (first_storage_id) - 1);
			call output ("^a thru ^a^vt^a", first_storage_id, ltrim (previous_storage_id),
			     print_data_info.value_column, first_value);
		     end;
	     end;

	call release_temp_segments_ ("print_data", temp_seg_ptrs, code);
	return;					/* End of print_data main proc. */

switch_source_and_target:
     proc;
	dcl     temp_ptr		        ptr;
	temp_ptr = target_ptr;
	target_ptr = source_ptr;
	source_ptr = temp_ptr;
     end;

check_level:
     proc (p_str, p_level, p_found);
	dcl     p_str		        char (*) varying;
	dcl     p_level		        fixed bin;
	dcl     p_found		        bit (1);
	dcl     idx		        fixed bin;
	dcl     next_level_ptr	        ptr;
	dcl     current_level_ptr	        ptr;
	dcl     1 level_id		        based,
		2 str		        char (32) varying,
		2 next		        ptr;

	current_level_ptr, next_level_ptr = root_of_level_list;
	do idx = 1 to p_level while (next_level_ptr ^= null);
	     current_level_ptr = next_level_ptr;
	     next_level_ptr = current_level_ptr -> level_id.next;
	end;
	if next_level_ptr ^= null			/* Implies p_level is less than length of level_list. */
	then do;
		if current_level_ptr -> level_id.str = p_str
		then do;
			p_found = "1"b;
			return;
		     end;
		else do;				/* Already printed component at this level is different than current component,
						   so the rest (higher levels) of the level_list is no longer appropriate. */
			current_level_ptr -> level_id.str = p_str;
			current_level_ptr -> level_id.next = null;
			current_level_ptr = next_level_ptr;
			do while (current_level_ptr ^= null);
			     next_level_ptr = current_level_ptr -> level_id.next;
			     free current_level_ptr -> level_id;
			     current_level_ptr = next_level_ptr;
			end;
			p_found = "0"b;
		     end;
	     end;
	else if idx = p_level
	then do;					/* This implies level_list is one shorter than p_level. */
		allocate level_id set (next_level_ptr);
		if current_level_ptr ^= null
		then current_level_ptr -> level_id.next = next_level_ptr;
		else root_of_level_list = next_level_ptr;
		next_level_ptr -> level_id.str = p_str;
		next_level_ptr -> level_id.next = null;
		p_found = "0"b;
	     end;
	else do;					/* idx > p_level */
		current_level_ptr -> level_id.str = p_str;
		p_found = "0"b;
	     end;
     end check_level;

setup_interval:
     proc (p_scan_idx);
	dcl     p_scan_idx		        fixed bin (24);
	dcl     start_scan_idx	        fixed bin (24);
	dcl     scan_length		        fixed bin (24);

	start_scan_idx = p_scan_idx;
	call get_interval (start_scan_idx, scan_length, more_intervals);
	p_scan_idx = scan_length + start_scan_idx;
	source_ptr -> temp_seg = rtrim (ltrim (substr (p_stuff, start_scan_idx, scan_length)));

/* All occurences of =" are expanded to =<SP>", ("=""" -> "= """).  Since this
   doesn't change number or ordering of quotes, this change does not alter the
   parsing of quoted strings.  It is necessary to insure proper parsing of
   storage id's from their values when their values are strings, bit or
   character.  */

	start_scan_idx = 1;
	target_ptr -> temp_seg = "";
	scan_length = index (source_ptr -> temp_seg, "=""");
	do while (scan_length > 0);
	     target_ptr -> temp_seg =
		target_ptr -> temp_seg || substr (source_ptr -> temp_seg, start_scan_idx, scan_length);
	     target_ptr -> temp_seg = target_ptr -> temp_seg || " ";
	     start_scan_idx = scan_length + start_scan_idx;
	     scan_length = index (substr (source_ptr -> temp_seg, start_scan_idx), "=""");
	end;

	target_ptr -> temp_seg = target_ptr -> temp_seg || substr (source_ptr -> temp_seg, start_scan_idx);
	call switch_source_and_target;
     end;



get_interval:
     proc (p_start_scan_idx, p_scan_length, p_more_intervals);
	dcl     p_start_scan_idx	        fixed bin (24);
	dcl     p_scan_length	        fixed bin (24);
	dcl     p_more_intervals	        bit (1);
	dcl     interval		        char (256) varying;
	dcl     interval_idx	        fixed bin;
	dcl     delimiter_idx	        fixed bin;
	dcl     start_scan_idx	        fixed bin (35);
	dcl     scan_length		        fixed bin (35);

	if interval_spec = ""
	then do;
		p_more_intervals = "0"b;
		p_scan_length = length (p_stuff) - p_start_scan_idx;
		return;
	     end;
	interval_idx = index (interval_spec, " ") - 1;
	if interval_idx = -1
	then interval_idx = length (interval_spec);
	interval = substr (interval_spec, 1, interval_idx);
	interval_spec = ltrim (substr (interval_spec, interval_idx + 1));
	delimiter_idx = index (interval, "|");
	if delimiter_idx = 0
	then do;
		p_start_scan_idx = index (substr (p_stuff, p_start_scan_idx), interval);
		p_start_scan_idx = p_start_scan_idx - index (reverse (substr (p_stuff, 1, p_start_scan_idx)), " ");
		source_ptr -> temp_seg = substr (p_stuff, p_start_scan_idx);
		p_scan_length = length (p_stuff);
		interval_spec = "";
		p_more_intervals = "0"b;
		return;
	     end;
	else if delimiter_idx = 1
	then do;
		p_scan_length = index (substr (p_stuff, p_start_scan_idx), substr (interval, 2));
		p_scan_length =
		     p_scan_length - index (reverse (substr (p_stuff, p_start_scan_idx, p_scan_length)), " ");
		source_ptr -> temp_seg = ltrim (rtrim (substr (p_stuff, p_start_scan_idx, p_scan_length)));
		p_scan_length = p_start_scan_idx + p_scan_length - 1;
		if interval_spec = ""
		then p_more_intervals = "0"b;
		else p_more_intervals = "1"b;
		return;
	     end;
	else if delimiter_idx = length (interval)
	then do;
		p_start_scan_idx = index (substr (p_stuff, p_start_scan_idx), interval);
		p_start_scan_idx = p_start_scan_idx - index (reverse (substr (p_stuff, 1, p_start_scan_idx)), " ");
		source_ptr -> temp_seg = substr (p_stuff, p_start_scan_idx);
		p_scan_length = length (p_stuff);
		interval_spec = "";
		p_more_intervals = "0"b;
		return;
	     end;
	else do;					/* Both a beginning and an end are given for the interval. */
		start_scan_idx = index (substr (p_stuff, p_start_scan_idx), substr (interval, 1, delimiter_idx - 1));
		start_scan_idx =
		     start_scan_idx - index (reverse (substr (p_stuff, p_start_scan_idx, start_scan_idx)), " ");
		p_start_scan_idx = start_scan_idx;
		scan_length = index (substr (p_stuff, p_start_scan_idx), substr (interval, delimiter_idx + 1));
		scan_length = scan_length - index (reverse (substr (p_stuff, p_start_scan_idx, scan_length)), " ");
		p_scan_length = scan_length;
		if interval_spec = ""
		then p_more_intervals = "0"b;
		else p_more_intervals = "1"b;
		return;
	     end;
     end;

	declare an_output		        char (1024);

output:
     procedure options (variable);

	declare cu_$generate_call	        entry (entry, ptr);
	declare cu_$arg_list_ptr	        entry returns (ptr);
	declare ioa_$general_rs	        entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21),
				        bit (1) aligned, bit (1) aligned);
	declare ioa_		        entry () options (variable);
	declare iox_$put_chars	        entry (ptr, ptr, fixed bin (21), fixed bin (35));
	declare used_length		        fixed bin (21);
	if rs_entry | (print_data_info.output_switch ^= null ())
	then do;
		call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, an_output, used_length, "0"b, "1"b);
		if rs_entry
		then p_return_string = p_return_string || substr (an_output, 1, used_length);
		else call iox_$put_chars (print_data_info.output_switch, addr (an_output), used_length, (0));
	     end;
	else call cu_$generate_call (ioa_, cu_$arg_list_ptr ());
	return;
     end output;

%include print_data_info;
     end print_data_;




		    suffix_bj_.pl1                  04/04/85  1114.9re  04/04/85  0824.7       95463



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

/* DESCRIPTION:

	This is the file system interface for before journals.  When
     the file system encounters an entity with a suffix of .bj, it
     calls suffix_bj_$validate.  If the entity is validated as a
     before journal, all future file system operations for the journal
     will be forwarded to this module (e.g., ACL manipulation).

	DEFINITION: a before journal is an unprotected Data
     Management file, with read and write ring brackets of the DM
     ring, and with a suffix of .bj on all its names in the containing
     directory.  The DM ring is defined as the ring of execution after
     transfering through dm_gate_, equal to sys_info$data_mgmt_ringno
     except in test DM systems.
*/

/* HISTORY:

Written by M. Pandolf, 10/31/83.
Modified:
02/29/84 by Michael Pandolf:  Changed to not call file_manager_
	  directly, but use fs_util_$make_entry_for_type.
06/11/84 by Lee Baldwin:  Renamed dm_error_$bj_header_bad to
	  $bj_bad_header.
12/14/84 by Lee A. Newcomb:  Changed to NOT use fs_util_$make_entry_for_type
	  as many file_manager_ operations are not supported for before
	  journals (e.g., switches); fixed to call before_journal_manager_
	  entrypoints as before journals are only available in the DM ring,
	  fixed $suffix_info to check the input version of the suffix_info
	  structure and to return error_table_$unsupported_operation for
	  for all unsupported file system operations not allowed for BJ's.
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo */
/* format: ^inddcls,dclind5,idind35,linecom */
%page;
suffix_bj_$suffix_info:
   proc (p_suffix_info_ptr);				/* START OF DECLARATIONS */

/* Parameter */
dcl  (
     p_acl_ptr			ptr,
     p_bit_count			fixed bin (24),
     p_code			fixed bin (35),
     p_copy_options_ptr		ptr,
     p_dir_name			char (*),
     p_entry_name			char (*),
     p_exmodes			bit (36) aligned,
     p_max_length			fixed bin (19),
     p_modes			bit (36) aligned,
     p_new_name			char (*),
     p_no_sysdaemon			bit (1),
     p_old_name			char (*),
     p_ring			fixed bin,
     p_ring_brackets		dim (*) fixed bin (3),
     p_switch_list_ptr		ptr,
     p_switch_name			char (*),
     p_suffix_info_ptr		ptr,
     p_user_area_ptr		ptr,
     p_user_name			char (*),
     p_value			bit (1) aligned,
     p_version_wanted		char (*)
     )				parameter;

/* Automatic */
dcl  (
     entrypoint_name		char (32)		/* set if ERROR_SIGNAL can be called */
     )				automatic;

/* Based */
/* Builtin */
dcl  (addr, null)			builtin;

/* Condition */
/* Constant */
dcl  (
     myname			char (32) varying init ("suffix_bj_"),
     IOA_GENERAL_RS_NO_NEW_LINE	bit (1) aligned init ("0"b),
     IOA_GENERAL_RS_DONT_PAD		bit (1) aligned init ("1"b)
     )				internal static options (constant);

/* Entry */
dcl  (
     before_journal_manager_$add_acl_entries
				entry (char (*), char (*), ptr,
				fixed bin (35)),
     before_journal_manager_$chname_file
				entry (char (*), char (*), char (*),
				char (*), fixed bin (35)),
     before_journal_manager_$delete_acl_entries
				entry (char (*), char (*), ptr,
				fixed bin (35)),
     before_journal_manager_$delete_bj	entry (char (*), char (*),
				fixed bin (35)),
     before_journal_manager_$get_user_access_modes
				entry (char (*), char (*), char (*),
				fixed bin, bit (36) aligned,
				bit (36) aligned, fixed bin (35)),
     before_journal_manager_$list_acl	entry (char (*), char (*), char (*),
				ptr, ptr, fixed bin (35)),
     before_journal_manager_$replace_acl
				entry (char (*), char (*), ptr, bit,
				fixed bin (35)),
     before_journal_manager_$validate	entry (char (*), char (*),
				fixed bin (35)),
     cu_$arg_list_ptr		entry (ptr),
     ioa_$general_rs		entry (ptr, fixed bin, fixed bin,
				char (*), fixed bin (21),
				bit (1) aligned, bit (1) aligned),
     sub_err_			entry () options (variable)
     )				external;

/* External */
dcl  (
     1 bj_suffix_info_$		aligned like suffix_info,
     bj_suffix_info_$version		char (8) aligned,
     (
     error_table_$null_info_ptr,
     error_table_$unimplemented_version,
     error_table_$unsupported_operation
     )				fixed bin (35)
     )				external static;

/* END OF DECLARATIONS */
%page;
/* DO SUPPORTED OPERATIONS WHOLLY CONTAINED IN THIS MODULE FIRST:	*/


/* repeat main procedure statement for reader's convenience:	*/
/*							*/
/* suffix_bj_$suffix_info:					*/
/*     proc (p_suffix_info_ptr);				*/

   suffix_info_ptr = p_suffix_info_ptr;
   entrypoint_name = "suffix_info";

   if suffix_info_ptr = null () then
      call ERROR_SIGNAL (error_table_$null_info_ptr,
	 "caller must allocate suffix_info storage.");
   else call CHECK_VERSION (bj_suffix_info_$version, suffix_info.version,
	   "suffix_info");

   suffix_info_ptr -> suffix_info = addr (bj_suffix_info_$) -> suffix_info;

   call RETURN ();
%page;
/* SUPPORTED OPERATIONS FOR WHICH WE MUST CALL	*/
/* before_journal_manager_ TO DO THE REAL WORK.	*/

suffix_bj_$add_acl_entries:
   entry (p_dir_name, p_entry_name, p_acl_ptr, p_code);

   call before_journal_manager_$add_acl_entries (p_dir_name, p_entry_name,
        p_acl_ptr, p_code);

   call RETURN ();

/* end suffix_bj_$add_acl_entries; */




suffix_bj_$chname_file:
   entry (p_dir_name, p_entry_name, p_old_name, p_new_name, p_code);

   call before_journal_manager_$chname_file (p_dir_name, p_entry_name,
        p_old_name, p_new_name, p_code);

   call RETURN ();

/* end suffix_bj_$chname_file; */




suffix_bj_$delentry_file:
   entry (p_dir_name, p_entry_name, p_code);

   call before_journal_manager_$delete_bj (p_dir_name, p_entry_name, p_code);

   call RETURN ();

/* end suffix_bj_$delentry_file; */




suffix_bj_$delete_acl_entries:
   entry (p_dir_name, p_entry_name, p_acl_ptr, p_code);

   call before_journal_manager_$delete_acl_entries (p_dir_name, p_entry_name,
        p_acl_ptr, p_code);

   call RETURN ();

/* end suffix_bj_$delete_acl_entries; */
%page;
suffix_bj_$get_user_access_modes:
   entry (p_dir_name, p_entry_name, p_user_name, p_ring, p_modes, p_exmodes,
        p_code);

   call before_journal_manager_$get_user_access_modes (p_dir_name,
        p_entry_name, p_user_name, p_ring, p_modes, p_exmodes, p_code);

   call RETURN ();

/* end suffix_bj_$get_user_access_modes; */




suffix_bj_$list_acl:
   entry (p_dir_name, p_entry_name, p_version_wanted, p_user_area_ptr,
        p_acl_ptr, p_code);

   call before_journal_manager_$list_acl (p_dir_name, p_entry_name,
        p_version_wanted, p_user_area_ptr, p_acl_ptr, p_code);

   call RETURN ();

/* end suffix_bj_$list_acl; */




suffix_bj_$replace_acl:
   entry (p_dir_name, p_entry_name, p_acl_ptr, p_no_sysdaemon, p_code);

   call before_journal_manager_$replace_acl (p_dir_name, p_entry_name,
        p_acl_ptr, p_no_sysdaemon, p_code);

   call RETURN ();

/* end suffix_bj_$replace_acl; */




suffix_bj_$validate:
   entry (p_dir_name, p_entry_name, p_code);

   call before_journal_manager_$validate (p_dir_name, p_entry_name, p_code);

   call RETURN ();

/* end suffix_bj_$validate; */
%page;
/* NOW HANDLE THOSE OPERATIONS NOT SUPPORTED FOR BEFORE JOURNALS.	*/
/* ALL ENTRIES FALL THROUGH TO SET THE STATUS CODE AND RETURN.	*/

suffix_bj_$add_extended_acl_entries:
   entry (p_dir_name, p_entry_name, p_acl_ptr, p_code);

suffix_bj_$copy:
   entry (p_copy_options_ptr, p_code);

suffix_bj_$get_bit_count:
   entry (p_dir_name, p_entry_name, p_bit_count, p_code);

suffix_bj_$get_max_length:
   entry (p_dir_name, p_entry_name, p_max_length, p_code);

suffix_bj_$get_ring_brackets:
   entry (p_dir_name, p_entry_name, p_ring_brackets, p_code);

suffix_bj_$get_switch:
   entry (p_dir_name, p_entry_name, p_switch_name, p_value, p_code);

suffix_bj_$list_extended_acl_entries:
   entry (p_dir_name, p_entry_name, p_version_wanted, p_user_area_ptr,
        p_acl_ptr, p_code);

suffix_bj_$list_switches:
   entry (p_dir_name, p_entry_name, p_switch_list_ptr, p_code);

suffix_bj_$replace_extended_acl:
   entry (p_dir_name, p_entry_name, p_acl_ptr, p_no_sysdaemon, p_code);

suffix_bj_$set_bit_count:
   entry (p_dir_name, p_entry_name, p_bit_count, p_code);

suffix_bj_$set_max_length:
   entry (p_dir_name, p_entry_name, p_max_length, p_code);

suffix_bj_$set_ring_brackets:
   entry (p_dir_name, p_entry_name, p_ring_brackets, p_code);

suffix_bj_$set_switch:
   entry (p_dir_name, p_entry_name, p_switch_name, p_value, p_code);

   call ERROR_RETURN (error_table_$unsupported_operation);
%page;
MAIN_RETURN:
   return;

RETURN:
   proc ();

/* This proc is used when 1) there is no code parameter to set, or	*/
/* 2) the code parameter has been set by an external procedure.	*/

   go to MAIN_RETURN;

   end RETURN;


ERROR_RETURN:
   proc (er_p_code);

dcl  er_p_code			fixed bin (35) parameter;

   p_code = er_p_code;
   go to MAIN_RETURN;

   end ERROR_RETURN;




CHECK_VERSION:
   proc (cv_p_expected_version, cv_p_given_version, cv_p_structure_name);

dcl  (
     cv_p_expected_version		char (8) aligned,
     cv_p_given_version		char (8) aligned,
     cv_p_structure_name		char (*)
     )				parameter;

   if cv_p_expected_version ^= cv_p_given_version then
      call ERROR_SIGNAL (error_table_$unimplemented_version,
	 "Expected version ^a of structure ^a, recieved ^a.",
	 cv_p_expected_version, cv_p_structure_name, cv_p_given_version);

   return;

   end CHECK_VERSION;
%page;
ERROR_SIGNAL:
   proc options (variable);

dcl  (
     er_arg_list_ptr		ptr,
     er_code			fixed bin (35),
     er_message			char (1024),
     er_message_length		fixed bin (21)
     )				automatic;

dcl  (
     er_fixed_bin_35_value		fixed bin (35),
     er_message_overlay		char (er_message_length)
     )				based;

   call cu_$arg_list_ptr (er_arg_list_ptr);
   er_code = er_arg_list_ptr -> arg_list.arg_ptrs (1) -> er_fixed_bin_35_value;

   call ioa_$general_rs (er_arg_list_ptr, 2, 3, er_message, er_message_length,
        IOA_GENERAL_RS_DONT_PAD, IOA_GENERAL_RS_NO_NEW_LINE);
   call sub_err_ (er_code, myname, ACTION_CANT_RESTART, null (), 0,
        "By entry ^a:  ^a.", entrypoint_name,
        addr (er_message) -> er_message_overlay);

   end ERROR_SIGNAL;
%page;
%include suffix_info;
%page;
%include copy_flags;
%page;
%include arg_list;
%page;
%include sub_err_flags;


   end suffix_bj_$suffix_info;




		    tm_get_state_description.pl1    01/04/85  0952.6re  01/03/85  1151.3       30654



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/* --------------- */

tm_get_state_description: proc (A_state) returns (char (*));

/* DESCRIPTION:

   Given a transaction's state (for example, tm_tdt.state (i)), returns
   a character string describing that state.
*/

/* HISTORY:

Written by Steve Herbst, 11/28/83.
Modified:
10/17/84 by Steve Herbst: Changed in response to audit comments.
*/


/* DECLARATIONS */

/* Parameters */

dcl  A_state fixed bin parameter;

/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl  string char (64);
dcl  state fixed bin;
dcl  error_sw bit (1);

/* External */

/* Entries */

dcl  ioa_$rsnnl entry options (variable);

/* Builtins */

dcl  (length, rtrim) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	state = A_state;
	if state > TM_ERROR_INCREMENT then do;
	     error_sw = "1"b;
	     state = state - TM_ERROR_INCREMENT;
	end;
	else error_sw = "0"b;

	if state = TM_IN_PROGRESS_STATE then string = "In Progress";
	else if state = TM_BEGIN_STARTING_STATE then string = "Begin, calling bjm_$write_begin_mark";
	else if state = TM_ABORT_FLUSHING_TXN_STATE then string = "Abort, calling bjm_$flush_transaction";
	else if state = TM_ABORT_ROLLING_BACK_STATE then string = "Abort, calling bjm_$rollback";
	else if state = TM_ABORT_FLUSHING_CI_STATE then string = "Abort, calling fm_$flush_modified_ci";
	else if state = TM_ABORT_WRITING_MARK_STATE then string = "Abort, calling bjm_$write_aborted_mark";
	else if state = TM_ABORT_UNLOCKING_STATE then string = "Abort completed, calling lm_$unlock_all";
	else if state = TM_ABORT_METERING_STATE then string = "Abort completed, metering";
	else if state = TM_COMMIT_FLUSHING_TXN_STATE then string = "Commit, calling bjm_$flush_transaction";
	else if state = TM_COMMIT_FLUSHING_CI_STATE then string = "Commit, calling fm_$flush_modified_ci";
	else if state = TM_COMMIT_WRITING_MARK_STATE then string = "Commit, calling bjm_$write_committed_mark";
	else if state = TM_COMMIT_POST_COMMIT_STATE then string = "Commit, post-commit";
	else if state = TM_COMMIT_UNLOCKING_STATE then string = "Commit completed, calling lm_$unlock_all";
	else if state = TM_COMMIT_METERING_STATE then string = "Commit completed, metering";
	else if state = TM_ROLLBACK_FLUSHING_TXN_STATE then string = "Rollback, calling bjm_$flush_transaction";
	else if state = TM_ROLLBACK_ROLLING_BACK_STATE then string = "Rollback, calling bjm_$rollback";
	else if state = TM_ROLLBACK_FLUSHING_CI_STATE then string = "Rollback, calling fm_$flush_modified_ci";
	else if state = TM_ROLLBACK_WRITING_MARK_STATE then string = "Rollback, calling bjm_$write_rolled_back_mark";
	else if state = TM_ROLLBACK_UNLOCKING_STATE then string = "Rollback completed, calling lm_$unlock_all";
	else if state = TM_ROLLBACK_METERING_STATE then string = "Rollback completed, metering";
	else call ioa_$rsnnl ("^d (undefined state)", string, length (string), A_state);

	if error_sw then return ("Error - " || rtrim (string));
	else return (rtrim (string));
%page;
%include dm_tm_states;


     end tm_get_state_description;




		    tm_get_state_info.pl1           01/04/85  0952.6re  01/03/85  1151.3       19809



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_get_state_info: proc (A_state, A_op_name, A_op_error_code);


/* DESCRIPTION:

   Given the state of a transaction left in error or part-way through a TM
   operation, returns the name of the interrupted operation and the appropriate
   error code dm_error_$unfinished_(abort commit rollback).
*/

/* HISTORY:

Written by Steve Herbst, 01/18/83.
Modified:
08/23/84 by Steve Herbst: Changed to use OP_NAME... constants.
10/17/84 by Steve Herbst: Changed in response to audit comments.
*/

/* DECLARATIONS */

/* Parameters */

dcl  A_state fixed bin parameter;
dcl  A_op_name char (*) parameter;
dcl  A_op_error_code fixed (35) parameter;


/* Constants */

/* Based */

/* Static */

/* Automatic */

dcl state fixed bin;

/* External */

dcl dm_error_$unfinished_abort fixed bin (35) ext;
dcl dm_error_$unfinished_commit fixed bin (35) ext;
dcl dm_error_$unfinished_rollback fixed bin (35) ext;

/* Entries */

/* Builtins */

/* Conditions */

/* END OF DECLARATIONS */
%page;
	if A_state > TM_ERROR_INCREMENT then		/* an error state */
	     state = A_state - TM_ERROR_INCREMENT;	/* look instead at the corresponding pre-call state */
	else state = A_state;

	if state >= LOWEST_ABORT_STATE & state <= HIGHEST_ABORT_STATE then do;
	     A_op_name = OP_NAME_ABORT;
	     A_op_error_code = dm_error_$unfinished_abort;
	end;
	else if state >= LOWEST_COMMIT_STATE & state <= HIGHEST_COMMIT_STATE then do;
	     A_op_name = OP_NAME_COMMIT;
	     A_op_error_code = dm_error_$unfinished_commit;
	end;
	else if state >= LOWEST_ROLLBACK_STATE & state <= HIGHEST_ROLLBACK_STATE then do;
	     A_op_name = OP_NAME_ROLLBACK;
	     A_op_error_code = dm_error_$unfinished_rollback;
	end;
	else do;
	     A_op_name = "";
	     A_op_error_code = 0;
	end;

	return;
%page;
%include dm_tm_states;


end tm_get_state_info;




		    tm_handle_conditions.pl1        01/04/85  0952.6re  01/03/85  1151.3       29205



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/* --------------- */

tm_handle_conditions: proc ();

/* DESCRIPTION:
   Suspends the current transaction, resignals the condition, and resumes
   the transaction. Called so that condition handlers execute with
   transactions suspended. Any program that begiins and commits transactions
   should say:
	on any_other call transaction_manager_$handle_conditions ();
*/

/* HISTORY:

Written by Steve Herbst, 01/10/83.
Modified:
01/11/83 by Steve Herbst: Made to suspend and resume.
01/25/83 by Steve Herbst: Changed to not check code from suspend before
	  resuming.
04/13/83 by Steve Herbst: Changed to call signal_ with the condition name.
05/18/83 by Lindsey L. Spratt:  Fixed to call signal_ with a fixed char string
            for the name, rather than the call by reference with
            auto_cond_info.condition_name since signal_ takes a nonvarying
            char name argument.  Also, fixed the code variable to be
            initialized to 0 (with an init in the dcl statement).
07/14/83 by Steve Herbst: Re-declared signal_ from options(variable) to
	  explicit args so that condition name will REALLY be passed as
	  a fixed-length string.
10/17/84 by Steve Herbst: Changed in response to audit comments.
*/

/* DECLARATIONS */

/* Parameters */

/* Constants */

/* Based */

/* Static */

dcl  recurse_sw bit (1) int static init ("0"b);		/* prevents recursive invocation */

/* Automatic */

dcl 1 auto_condition_info aligned like condition_info;
dcl resume_sw bit (1);
dcl code fixed bin (35) init (0);

/* External */

/* Entries */

dcl continue_to_signal_ entry (fixed bin (35));
dcl find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl signal_ entry (char (*), ptr, ptr, ptr);
dcl transaction_manager_$resume_txn entry (fixed bin (35));
dcl transaction_manager_$suspend_txn entry (fixed bin (35));

/* Builtins */

dcl (addr, null, unspec) builtin;

/* Conditions */

dcl cleanup condition;

/* END OF DECLARATIONS */
%page;
	if recurse_sw then do;			/* prevent recursive loop */
	     call continue_to_signal_ (0);
	     return;
	end;

	resume_sw = "0"b;
	on cleanup call CLEAN_UP;

	recurse_sw = "1"b;

	call transaction_manager_$suspend_txn (code);
	resume_sw = (code = 0);			/* don't resume if transaction was previously suspended */

	unspec (auto_condition_info) = "0"b;
	auto_condition_info.version = condition_info_version_1;

	call find_condition_info_ (null, addr (auto_condition_info), code);
	if code = 0
	then call signal_ ((auto_condition_info.condition_name), auto_condition_info.mc_ptr,
		auto_condition_info.info_ptr, auto_condition_info.wc_ptr);

	call CLEAN_UP;

	return;
%page;
CLEAN_UP: proc;

	recurse_sw = "0"b;

	if resume_sw then call transaction_manager_$resume_txn (0);

end CLEAN_UP;
%page;
%include condition_info;
%page;
%include sub_error_info;
%page;
%include condition_info_header;


end tm_handle_conditions;




		    tm_no_firstref_tv_.alm          04/24/85  1022.3re  04/24/85  0803.3       11295



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************
"
"  DESCRIPTION:
"
"          This is one of the two Data Management transaction manager transfer
"     vectors.  This one, tm_no_firstref_tv_, is for each transaction manager
"     entry which does not require Data Management per-process initialization
"     to have been executed at some time before the transaction manager entry
"     itself is executed.  Entries which require Data Management per-process 
"     initialization go through tm_firstref_tv_, which has a first
"     reference trap is associated with tm_firstref_tv_ which runs per-process
"     initialization the first time tm_firstref_tv_ is invoked.
"
"
" HISTORY:
"
" Written by Lee A. Newcomb, 04/17/85.
" Modified:
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	name	tm_no_firstref_tv_

	macro	transfer
	entry	&1
&1:
	tra	&2

	&end


" only one entry currently
	transfer	user_shutdown_real,tm_user_shutdown_real$tm_user_shutdown_real


	end




		    tm_per_system_init.pl1          01/04/85  0952.6re  01/03/85  1151.3       15480



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/* --------------- */

tm_per_system_init: proc (A_code);

/* DESCRIPTION:

   This  procedure,  called  at  system  initialization time, allocates
   transaction_manager_'s Transaction Definition Table (TDT)  and  puts  its
   relp in dm_system_data_$tm_tdt_relp.
*/

/* HISTORY:

Written by Steve Herbst, 08/16/82.
Modified:
08/05/83 by Lee A. Newcomb: Removed code argument from calls to dm_per_system_
	since errors are now reported via sub_err_.
10/17/84 by Steve Herbst: Changed in response to audit comments.
*/

/* DECLARATIONS */

/* Parameters */

dcl A_code fixed bin (35) parameter;



/* Constants */

/* Based */

/* Static */

/* Automatic */

/* External */

dcl dm_system_data_$max_n_transactions fixed bin external;
dcl dm_system_data_$tm_tdt_relp bit (18) external;

/* Entries */

dcl dm_per_system_$alloc entry (fixed bin, ptr);

/* Builtins */

dcl (rel, size, unspec) builtin;

/* Conditions */

/* END OF DECLARATIONS */
%page;
	A_code = 0;

	tdt_max_count = dm_system_data_$max_n_transactions;

	call dm_per_system_$alloc (size (tm_tdt), tm_tdt_ptr);

	unspec (tm_tdt) = "0"b;

	tm_tdt.version = TM_TDT_VERSION_3;
	tm_tdt.entry_count = dm_system_data_$max_n_transactions; /* just in case $alloc didn't set it */

	dm_system_data_$tm_tdt_relp = rel (tm_tdt_ptr);

	return;
%page;
%include dm_tm_tdt;


end tm_per_system_init;




		    tm_user_shutdown.pl1            04/24/85  1022.4re  04/24/85  0803.3       27063



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

/*  DESCRIPTION:

		tm_user_shutdown

     This routine does the user ring portion of Data Management user
shutdown.  The steps are outlined below.  IPS interrupts are not
masked as they cannot cause any damage unless the user has created his
own dm_misc_util_, etc., in an attempt to do so.

     In the original code, all user shutdown was done in the DM ring.
However, this left the timers set; if the process then used another DM
system, a segment fault would result trying to reference through the
old entry variables stored by timer_manager_.  In addition, the user
would get rather confused to find multiple timers set up to do the DM
user shutdown steps.

 Shutdown Steps:
1) reset the user shutdown warning timer;

2) reset the user shutdown timer;

3) call transaction_manager_$user_shutdown_real to cause DM shutdown
in the inner ring (DM user shutdown is not complete until this call
returns).
*/

/*  HISTORY:

Written by Lee A. Newcomb, 04/17/85.
Modified:
*/

/* format: style2,ll79,ind3,^indprocbody,ifthendo,ifthen,^indnoniterdo,^inddcls,dclind5,idind35,linecom */
%page;
tm_user_shutdown:
   proc (p_area_ptr, p_tm_shutdown_info_ptr, p_code);


/* DECLARATIONS */

/* Parameter */
dcl  (
     p_area_ptr			ptr,		/* I: user area to allocate tm_shutdown_info */
     p_tm_shutdown_info_ptr		ptr,		/* O: where tm_shutdown_info was allocated */
     p_code			fixed bin (35)	/* O: normal error code, recovery fails if ^= 0 */
     )				parameter;

/* Condition */
dcl  timer_manager_err		condition;

/* Entry */
dcl  (
     dm_misc_util_$is_process_using_dm	entry () returns (bit (1) aligned),
     dm_misc_util_$shutdown_handler	entry (),
     dm_misc_util_$signal_shutdown_warning
				entry (),
     dm_misc_util_$signal_user_shutdown entry (),
     timer_manager_$reset_alarm_call	entry (entry),
     transaction_manager_$user_shutdown_real
				entry (ptr, ptr, fixed bin (35))
     )				external;

/* END OF DECLARATIONS */
%page;
/* tm_user_shutdown:		repeat for reader	*/
/*    proc (ptr, ptr, fixed bin(35));			*/


RESET_USER_DM_SHUTDOWN_TIMERS:
   do;						/* two timers to reset */
      on timer_manager_err go to RESET_USER_SHUTDOWN_TIMER;
      call timer_manager_$reset_alarm_call (
	 dm_misc_util_$signal_shutdown_warning);
RESET_USER_SHUTDOWN_TIMER:
      on timer_manager_err go to USER_SHUTDOWN_TIMERS_RESET;
      call timer_manager_$reset_alarm_call (dm_misc_util_$signal_user_shutdown)
	 ;
USER_SHUTDOWN_TIMERS_RESET:
   end RESET_USER_DM_SHUTDOWN_TIMERS;


DO_DM_RING_USER_SHUTDOWN:
   call transaction_manager_$user_shutdown_real (p_area_ptr,
        p_tm_shutdown_info_ptr, p_code);

   return;

/* end tm_user_shutdown; */


   end tm_user_shutdown;




		    tm_user_shutdown_real.pl1       05/06/86  1320.6rew 05/06/86  1257.2       49923



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


/****^  HISTORY COMMENTS:
  1) change(86-02-27,Pierret), approve(86-02-27,MCR7340),
     audit(86-04-28,Newcomb), install(86-05-06,MR12.0-1054):
     Changed to use dm_misc_util_$is_process_using_dm instead of using the gate
     entry directly.
                                                   END HISTORY COMMENTS */


/* format: style2,ifthenstmt,^indproc,^indcomtxt */
/*---------------*/

tm_user_shutdown_real:
     proc (A_area_ptr, A_tm_shutdown_info_ptr, A_code);

/* DESCRIPTION:

     	This program shuts down (terminates) a process' usage of a
     Data Management System (DMS).  It is mainly called by the static
     handler for the dm_user_shutdown_ IPS and by the terminate_dm
     command.  It does the following:

     1) returns if the process is not using a DMS,
     2) calls transaction_manager_$user_shutdown_adjust,
     3) call the other DM inner ring managers to do whatever steps
        necessary for them to do user shutdown,
     4) calls transaction_manager_$user_shutdown_free,
     5) terminates (shuts down) the user references to the DMS.

	Note that IPS interrupts are masked while the above steps are
     being done to shut a very small window between each one.  This is to
     prevent possible future problems for processes logged in from rings
     lower than or equal to the DM ring.
*/

/* HISTORY:

Written by Steve Herbst, 11/28/83.
Modified:
02/16/84 by S. Herbst: Fixed to free a TDT entry if no txn left in it.
05/01/84 by L. A. Newcomb: Changed to fix several problems and to call
	  other inner ring manager's user shutdown entrypoints.
05/16/84 by S. Herbst: Changed to return first nonzero error code from 
	  its various calls.
05/31/84 by Lindsey L. Spratt:  Fixed to do the "is_using_dm" check after
            masking ips signals.  Changed the clean_up proc to be the FINISH
            proc, which is always called before returning.  Added the RETURN
            proc which calls FINISH and goes to MAIN_RETURN.  Extended FINISH
            to only free the tm_shutdown_info if the tsi ptr is different from
            the A_tsi ptr and is non-null, allowing the FINISH proc to be used
            after setting the A_tsi ptr without causing the tsi structure to
            be freed.
10/23/84 by Steve Herbst: Changed in response to audit comments.
12/07/84 by R. Michael Tague: Changed dm_util_$terminate_dm to dm_misc_util_$=.
01/31/85 by Steve Herbst: Allow null A_area_ptr, don't set
	  A_tm_shutdown_info_ptr.
05/08/85 by Lee A. Newcomb:  Fixed to use dm_misc_util_$is_process_using_dm to
            follow project standard instead of directly calling the gate
            entry.
*/

/* DECLARATIONS */

/* Parameters */

	dcl     A_area_ptr		 ptr parameter;
	dcl     A_tm_shutdown_info_ptr ptr parameter;
	dcl     A_code		 fixed bin (35) parameter;

/* Constants */

/* Based */

	dcl     based_area		 area based;

/* Automatic */

	dcl     area_ptr		 ptr;
	dcl     saved_ips_mask	 bit (36) aligned;
	dcl     code		 fixed bin (35);

/* Entries */

	dcl     before_journal_manager_$user_shutdown
				 entry ();
	dcl     dm_misc_util_$terminate_dm
				 entry (fixed bin (35));
	dcl     dm_misc_util_$is_process_using_dm
				 entry returns (bit (1));
	dcl     file_manager_$user_shutdown
				 entry ();
	dcl     get_system_free_area_	 entry returns (ptr);
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     lock_manager_$user_shutdown
				 entry ();
	dcl     transaction_manager_$user_shutdown_adjust
				 entry (ptr, ptr, fixed bin (35));
	dcl     transaction_manager_$user_shutdown_free
				 entry (fixed bin (35));

/* Builtins */

	dcl     null		 builtin;

/* Conditions */

	dcl     cleanup		 condition;

/* END OF DECLARATIONS */
%page;
	A_code = 0;
	A_tm_shutdown_info_ptr = null;
	tm_shutdown_info_ptr = null;

	if A_area_ptr ^= null
	then area_ptr = A_area_ptr;
	else area_ptr = get_system_free_area_ ();

	saved_ips_mask = ""b;
	on cleanup call FINISH ();

	call hcs_$set_ips_mask (""b, saved_ips_mask);
	if ^dm_misc_util_$is_process_using_dm ()
	then do;					/* DM not initialized, */
		call FINISH ();			/* our work is done. */
		return;
	     end;

	call transaction_manager_$user_shutdown_adjust (area_ptr, tm_shutdown_info_ptr, code);
	if code ^= 0 & A_code = 0 then A_code = code;

/* call the other DM-ring managers to do whatever they must */

	call lock_manager_$user_shutdown ();
	call before_journal_manager_$user_shutdown ();
	call file_manager_$user_shutdown ();

/* now free TDT entries, reset the first reference traps, and reset IPS mask */

	call transaction_manager_$user_shutdown_free (code);
	if code ^= 0 & A_code = 0 then A_code = code;

	call dm_misc_util_$terminate_dm (code);
	if code ^= 0 & A_code = 0 then A_code = code;

	if A_area_ptr ^= null then A_tm_shutdown_info_ptr = tm_shutdown_info_ptr;

	call FINISH ();

	return;
%page;
FINISH:
     proc;

	if A_tm_shutdown_info_ptr ^= tm_shutdown_info_ptr & tm_shutdown_info_ptr ^= null
	then free tm_shutdown_info in (area_ptr -> based_area);

	if saved_ips_mask ^= ""b then call hcs_$set_ips_mask (saved_ips_mask, saved_ips_mask);

     end FINISH;
%page;
%include dm_tm_shutdown_info;


     end tm_user_shutdown_real;




		    transaction.pl1                 11/10/86  0921.0rew 11/10/86  0849.7      419418



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


/****^  HISTORY COMMENTS:
  1) change(86-04-15,Pierret), approve(86-04-15,MCR7279),
     audit(86-07-30,Gilcrease), install(86-08-01,MR12.0-1113):
     DM error 29: Changed to not look at all tm_tdt entries unless absolutely
     necessary so that non-priviledged uses can use transaction status.
  2) change(86-04-15,Pierret), approve(86-04-15,MCR7279),
     audit(86-07-30,Gilcrease), install(86-08-01,MR12.0-1113):
     DM error 30: Changed to reset handler_invoked_sw to off after the
     return from transaction_manager_$handle_conditions in the processing
     of the SUSPEND_ACTION.
  3) change(86-04-15,Pierret), approve(86-04-15,MCR7279),
     audit(86-07-30,Gilcrease), install(86-08-01,MR12.0-1113):
     DM error 31:  Changed loop which calls PRINT_ENTRY to use tix_index
     instead of tix_count, thereby printing all entries instead of the last
     one repeatedly.
  4) change(86-09-30,Blair), approve(86-10-22,MCR7567), audit(86-11-06,Dupuis),
     install(86-11-10,MR12.0-1207):
     Reset the handler_invoked_sw after signalling the condition so that we can
     detect when a condition occurs more than once.  TR 19757.
                                                   END HISTORY COMMENTS */


/* format: style4,ifthenstmt,^indproc,^indcomtxt */
/* --------------- */

transaction: txn: proc;

/* DESCRIPTION:

   Command interface to the Data Management System.
*/

/* HISTORY:

Written by Steve Herbst, 02/20/84.
Modified:
03/08/84 by Steve Herbst: Fixed general usage message.
03/21/84 by Steve Herbst: Fixed bug in "txn execute" condition handling.
03/21/84 by Steve Herbst: Changed "txn abandon" and "txn abort" to resume
	suspended txn.
11/08/84 by Steve Herbst: Changed in response to audit comments.
04/02/84 by Lee A. Newcomb: Fixed dcl of tm_$get_state_description to be
	char(*) as in called entry instead of char (64); called was reading
	stack garbage when trying to decode descriptor.
04/03/84 by Lee A. Newcomb: Fixed status' using the wrong buffer when
	outputing a txn's state.
04/19/84 by Lindsey L. Spratt: Corrected the calling sequence of the
	transaction_manager_$rollback_txn entry to include the checkpoint id.
04/23/84 by Lindsey L. Spratt: Fixed to only handle the
	dm_error_$system_not_initialized sub_error_ in the sub_error_
	handler.
04/26/84 by Lindsey L. Spratt: Changed to always abort on the cleanup
	condition, and to do a non-local goto RETURN when aborting or
	abandoning any condition other than a cleanup.
04/27/84 by Lindsey L. Spratt: Made all settings of severities use declared
	constants.  Fixed to always set the severity in the execute
	operation, regardless of the path of execution, if txn is invoked
	as an active function.
05/10/84 by S. Herbst: Fixed to get BJ path from oid if possible, without
	(as for from_uid) requiring special gate access.
05/16/84 by S. Herbst: Fixed "txn execute" to prompt for command_line if
	given neither a command_line nor -command_level.
05/21/84 by S. Herbst: Fixed "txn begin" error msg for bad control arg.
11/08/84 by Steve Herbst: Changed in response to audit comments.
11/27/84 by Steve Herbst: Changed further in response to audit comments.
01/02/85 by Steve Herbst: Fixed "txn execute" to set transaction_severity_
	external variable for use by severity command.
01/22/85 by Steve Herbst: Fixed CURRENT_ID proc to set af value to "false"
	rather than issue an error.
01/29/85 by Steve Herbst: Fixed CURRENT_ID to return txn_id even if txn is
	in an error state; changed to accept txn_id's as decimal integers.
02/20/85 by Steve Herbst: Fixed to handle dm_not_available_.
*/
%page;
/* DECLARATIONS */

/* Constants */

dcl  KEY_NAMES (8) char (32) int static options (constant)
	init ("abandon", "abort", "begin", "commit", "execute", "kill", "rollback", "status");
dcl  (
     EXISTING_TXN_NOT_ALLOWED init (1),
     EXISTING_TXN_ALLOWED init (2),
     EXISTING_TXN_REQUIRED init (3)
     ) fixed bin int static options (constant);
dcl  (
     ABANDON_ACTION init (1),
     ABORT_ACTION init (2),
     NO_ACTION init (3),
     RETRY_ACTION init (4),
     SUSPEND_ACTION init (5)
     ) fixed bin int static options (constant);

dcl  (
     NO_ERROR_SEVERITY init (0),
     RETRY_SEVERITY init (1),
     ABORT_OR_ABANDON_SEVERITY init (2),
     FAILED_ABORT_OR_ABANDON_SEVERITY init (3),
     FATAL_SEVERITY init (4)
     ) fixed bin (35) internal static options (constant);

dcl  (
     ENTRY_ITEM init (1),
     TXN_ITEM init (2)
     ) fixed bin int static options (constant);
dcl  INITIAL_CHECKPOINT init (0) fixed bin internal static options (constant);
dcl  PRINT_ALL_INFO bit (36) int static options (constant) init ((36)"1"b);
dcl  RELATIVE_TIME_OPTION bit (2) int static options (constant) init ("11"b);
dcl  (
     TEN_SECONDS init (10),
     USEC_PER_SECOND init (1000000),
     LONG_TIME_USEC init (1000000000000)
     ) fixed bin (71) int static options (constant);

/* Based */

dcl  1 handler_node aligned based,
       2 next_ptr ptr,
       2 condition_name char (32),
       2 action fixed bin,
       2 retry_limit fixed bin;

dcl  1 tm_info (tdt_max_count) aligned like txn_info based (tm_info_ptr);

dcl  tix (tix_bound) fixed bin based (tix_ptr);

dcl  area area based (area_ptr);

dcl  arg char (arg_len) based (arg_ptr);
dcl  key char (key_len) based (key_ptr);
dcl  return_arg char (return_len) varying based (return_ptr);

/* Automatic */

dcl  1 print_switches aligned,
       2 (bj_path, dtm, errors, owner, pid, rollback_count, state, switches, tid, tix) bit (1) unaligned,
       2 pad bit (26) unaligned;

dcl  1 select_switches aligned,
       2 (abandoned, all, dead, tid, tix) bit (1) unaligned,
       2 pad bit (31) unaligned;

dcl  1 cond_info aligned like condition_info;

dcl  (key_buffer, my_name, on_action_name) char (32);
dcl  (begun_time_str, ctl_args_str, requested_time_str) char (32);

dcl  (af_sw, cl_sw, had_to_wait_sw, handler_invoked_sw, multiple_info_sw, on_action_specified_sw) bit (1);
dcl  (print_no_txn_warning_sw, printed_something_sw, succeeded_sw, total_sw) bit (1);
dcl  (txn_exists_sw, txn_existed_sw, wait_sw) bit (1);
dcl  bj_opening_id bit (36);
dcl  txn_id bit (36) aligned;

dcl  (alp, area_ptr, arg_ptr, first_handler_ptr, key_ptr, return_ptr, tix_ptr, tm_info_ptr) ptr;

dcl  (arg_count, arg_index, command_line_start, existing_txn_policy) fixed bin;
dcl  (fixed_txn_id, key_index, tix_index, tdt_index, txn_index) fixed bin;
dcl  (retry_count, retry_limit, tdt_max_count, tix_bound, tix_count, wait_seconds) fixed bin;
dcl  (abandoned_count, dead_count, error_count, txn_count, used_count) fixed bin;
dcl  (arg_len, key_len, return_len) fixed bin (21);
dcl  code fixed bin (35);
dcl  (start_usec, wait_usec) fixed bin (71);

dcl  (complain, complain_suppress_name) entry variable options (variable);

/* External */

dcl  dm_error_$system_not_initialized fixed bin (35) ext;
dcl  dm_error_$transaction_suspended fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$not_act_fnc fixed bin (35) ext;
dcl  error_table_$too_many_args fixed bin (35) ext;
dcl  transaction_severity_ fixed bin ext;

/* Entries */

dcl  (
     active_fnc_err_,
     active_fnc_err_$suppress_name
     ) entry options (variable);
dcl  before_journal_manager_$get_bj_path_from_oid entry (bit (36) aligned, char (*), char (*), fixed bin (35));
dcl  before_journal_manager_$get_bj_path_from_uid entry (bit (36) aligned, char (*), char (*), fixed bin (35));
dcl  (
     com_err_,
     com_err_$suppress_name
     ) entry options (variable);
dcl  command_query_ entry options (variable);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  convert_status_code_ entry (fixed bin (35), char (8), char (100));
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  find_condition_info_ entry (ptr, ptr, fixed bin (35));
dcl  get_process_id_ entry returns (bit (36));
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$validate_processid entry (bit (36) aligned, fixed bin (35));
dcl  (
     ioa_,
     ioa_$rsnnl
     ) entry options (variable);
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  transaction_manager_$abandon_txn entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$abort_txn entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$begin_txn entry (fixed bin, bit (36), bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$commit_txn entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$get_current_txn_id entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$get_state_description entry (fixed bin) returns (char (*));
dcl  transaction_manager_$get_tdt_size entry (fixed bin);
dcl  transaction_manager_$get_txn_index entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl  transaction_manager_$get_txn_info_index entry (fixed bin, ptr, fixed bin (35));
dcl  transaction_manager_$handle_conditions entry ();
dcl  transaction_manager_$kill_txn entry (bit (36) aligned, fixed bin (35));
dcl  transaction_manager_$resume_txn entry (fixed bin (35));
dcl  transaction_manager_$rollback_txn entry (bit (36) aligned, fixed bin, fixed bin (35));

/* Builtins */

dcl  (addr, addrel, character, clock, fixed, hbound, index, length, ltrim, null, rtrim, substr, unspec, verify) builtin;

/* Conditions */

dcl  (any_other, cleanup, dm_not_available_, sub_error_) condition;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	     complain_suppress_name = active_fnc_err_$suppress_name;
	end;
	else if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     complain_suppress_name = com_err_$suppress_name;
	end;
	else do;
	     call com_err_ (code, "transaction");
	     call ERROR_RETURN ();
	end;

	if arg_count = 0 then do;
	     my_name = "txn key";
	     call complain_suppress_name (error_table_$noarg, "transaction", "^a", USAGE_STRING ("{other_args}"));
	     call ERROR_RETURN ();
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call complain (code, "transaction", "Argument 1.");
	     call ERROR_RETURN ();
	end;

	if arg = "e" | arg = "st" then do;
	     key_ptr = addr (key_buffer);
	     key_len = length (key_buffer);
	     if arg = "e"
	     then key = "execute";
	     else key = "status";
	end;
	else do;
	     key_ptr = arg_ptr;
	     key_len = arg_len;
	end;

	do key_index = hbound (KEY_NAMES, 1) by -1 to 1 while (KEY_NAMES (key_index) ^= key);
	end;
	if key_index = 0 then do;
	     call complain (0, "transaction", "Invalid key argument ^a", arg);
	     call ERROR_RETURN ();
	end;

	my_name = "txn " || rtrim (KEY_NAMES (key_index));

	on dm_not_available_ begin;
	     call complain (dm_error_$system_not_initialized, my_name);
	     call ERROR_RETURN ();
	end;

	go to KEY (key_index);
RETURN:
	return;
%page;
/* "txn abandon" */
KEY (1):
	if arg_count > 1 then do;
	     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
	     call ERROR_RETURN ();
	end;

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then go to ABANDON_ATTEMPTED;
	end;

	call transaction_manager_$abandon_txn (CURRENT_ID (), code);
ABANDON_ATTEMPTED:
	if code ^= 0 then do;
	     if af_sw
	     then return_arg = "false";
	     else call complain (code, my_name);
	end;
	else do;
	     if af_sw then return_arg = "true";
	end;

	return;
%page;
/* txn abort */
KEY (2):
	if arg_count > 1 then do;
	     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
	     call ERROR_RETURN ();
	end;

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then go to ABORT_ATTEMPTED;
	end;

	call transaction_manager_$abort_txn (CURRENT_ID (), code);
ABORT_ATTEMPTED:
	if code ^= 0 then do;
	     if af_sw
	     then return_arg = "false";
	     else call complain (code, my_name);
	end;
	else do;
	     if af_sw then return_arg = "true";
	end;

	return;
%page;
/* txn begin */
KEY (3):
	wait_sw = "0"b;
	wait_usec = LONG_TIME_USEC;

	do arg_index = 2 to arg_count;

	     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);

	     if index (arg, "-") ^= 1 then do;
		call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING ("{-control_args}"));
		call ERROR_RETURN ();
	     end;

	     else if arg = "-no_wait" | arg = "-nwt" then wait_sw = "0"b;

	     else if arg = "-wait" | arg = "-wt" then do;
		arg_index = arg_index + 1;
		if arg_index > arg_count then do;
		     call complain (0, my_name, "No value specified for -wait");
		     call ERROR_RETURN ();
		end;
		call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
		wait_seconds = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     call complain (code, my_name, "Invalid -wait number of seconds ^a", arg);
		     call ERROR_RETURN ();
		end;
		wait_sw = "1"b;
		wait_usec = (wait_seconds + TEN_SECONDS) * USEC_PER_SECOND;
						/* extra 10 because that's how often we try */
	     end;

	     else if arg = "-wait_indefinitely" | arg = "-wti" then do;
		wait_sw = "1"b;
		wait_usec = LONG_TIME_USEC;
	     end;

	     else do;
		call complain (error_table_$badopt, my_name, "^a", arg);
		call ERROR_RETURN ();
	     end;
	end;

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then go to BEGIN_ATTEMPTED;
	end;

	bj_opening_id = "0"b;			/* use default BJ */

	start_usec = clock ();
	had_to_wait_sw = "0"b;

	do while (^had_to_wait_sw | clock () - start_usec < wait_usec);

	     call transaction_manager_$begin_txn (TM_NORMAL_MODE, bj_opening_id, txn_id, code);
BEGIN_ATTEMPTED:
	     if code = 0 then do;
		if had_to_wait_sw then do;
		     call date_time_ (start_usec, requested_time_str);
		     call date_time_ (clock (), begun_time_str);
		     call ioa_ ("Transaction requested at ^a begun ^a", requested_time_str, begun_time_str);
		end;
		if af_sw then return_arg = "true";
		return;
	     end;
	     else if ^wait_sw | code ^= dm_error_$system_not_initialized then do;
		if af_sw then return_arg = "false";
		else call complain (code, my_name);
		call ERROR_RETURN ();
	     end;

/* Wait 10 seconds */

	     call timer_manager_$sleep (TEN_SECONDS, RELATIVE_TIME_OPTION);
	     had_to_wait_sw = "1"b;
	end;

	if af_sw then return_arg = "false";
	else call complain (0, my_name, "Data Management not available within ^a seconds.", wait_seconds);

	call ERROR_RETURN ();
%page;
/* txn commit */
KEY (4):
	if arg_count > 1 then do;
	     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
	     call ERROR_RETURN ();
	end;

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then go to COMMIT_ATTEMPTED;
	end;

	call transaction_manager_$commit_txn (CURRENT_ID (), code);
COMMIT_ATTEMPTED:
	if code ^= 0 then do;
	     if af_sw then return_arg = "false";
	     else call complain (code, my_name);
	end;
	else if af_sw then return_arg = "true";

	return;
%page;
/* txn execute */
KEY (5):
	cl_sw, on_action_specified_sw, wait_sw = "0"b;
	existing_txn_policy = EXISTING_TXN_NOT_ALLOWED;
	wait_usec = LONG_TIME_USEC;
	retry_count = 0;
	transaction_severity_ = FATAL_SEVERITY;

/* Test for existing transaction */

	call transaction_manager_$get_current_txn_id (txn_id, code);
	txn_existed_sw = (code = 0);

	area_ptr = get_system_free_area_ ();
	first_handler_ptr = null;
	if ^txn_existed_sw then do;			/* set up default handlers */
	     call SAVE_HANDLER ("cleanup", ABORT_ACTION, 0);
	     call SAVE_HANDLER ("any_other", SUSPEND_ACTION, 0);
	end;

	call cu_$arg_list_ptr (alp);

	command_line_start = 0;
	do arg_index = 2 to arg_count while (command_line_start = 0);

	     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);

	     if index (arg, "-") ^= 1 then command_line_start = arg_index;

	     else if arg = "-abandon_on" then do;
		call GET_CONDITION_LIST ("-abandon_on", arg_index, ABANDON_ACTION, 0);
		if ^on_action_specified_sw then do;
		     on_action_specified_sw = "1"b;
		     on_action_name = "-abandon_on";
		end;
	     end;

	     else if arg = "-abort_on" then do;
		call GET_CONDITION_LIST ("-abort_on", arg_index, ABORT_ACTION, 0);
		if ^on_action_specified_sw then do;
		     on_action_specified_sw = "1"b;
		     on_action_name = "-abort_on";
		end;
	     end;

	     else if arg = "-command_level" | arg = "-cl" then cl_sw = "1"b;

	     else if arg = "-existing_transaction_allowed" | arg = "-eta"
	     then existing_txn_policy = EXISTING_TXN_ALLOWED;

	     else if arg = "-existing_transaction_required" | arg = "-etr"
	     then existing_txn_policy = EXISTING_TXN_REQUIRED;

	     else if arg = "-no_action_on" then do;
		call GET_CONDITION_LIST ("-no_action_on", arg_index, NO_ACTION, 0);
		if ^on_action_specified_sw then do;
		     on_action_specified_sw = "1"b;
		     on_action_name = "-no_action_on";
		end;
	     end;

	     else if arg = "-no_existing_transaction_allowed" | arg = "-neta"
	     then existing_txn_policy = EXISTING_TXN_NOT_ALLOWED;

	     else if arg = "-no_wait" | arg = "-nwt" then wait_sw = "0"b;

	     else if arg = "-retry_on" then do;
		arg_index = arg_index + 1;
		call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
		if arg_index > arg_count then do;
		     call complain (0, my_name, "No number or condition list specified for -retry_on");
		     call ERROR_RETURN ();
		end;
		retry_limit = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     call complain (code, my_name, "Invalid count ^a for -retry_on", arg);
		     call ERROR_RETURN ();
		end;
		call GET_CONDITION_LIST ("-retry_on", arg_index, RETRY_ACTION, retry_limit);
		if ^on_action_specified_sw then do;
		     on_action_specified_sw = "1"b;
		     on_action_name = "-retry_on";
		end;
	     end;

	     else if arg = "-suspend_on" then do;
		call GET_CONDITION_LIST ("-suspend_on", arg_index, SUSPEND_ACTION, 0);
		if ^on_action_specified_sw then do;
		     on_action_specified_sw = "1"b;
		     on_action_name = "-suspend_on";
		end;
	     end;

	     else if arg = "-wait" | arg = "-wt" then do;
		arg_index = arg_index + 1;
		if arg_index > arg_count then do;
		     call complain (0, my_name, "No value specified for -wait");
		     call ERROR_RETURN ();
		end;
		call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
		wait_seconds = cv_dec_check_ (arg, code);
		if code ^= 0 then do;
		     call complain (code, my_name, "^a", arg);
		     call ERROR_RETURN ();
		end;
		wait_sw = "1"b;
		wait_usec = (wait_seconds + TEN_SECONDS) * USEC_PER_SECOND;
						/* extra 10 because that's how often we try */
	     end;

	     else if arg = "-wait_indefinitely" | arg = "-wti" then do;
		wait_sw = "1"b;
		wait_usec = LONG_TIME_USEC;
	     end;

	     else do;
		call complain (error_table_$badopt, my_name, "^a", arg);
		call ERROR_RETURN ();
	     end;
	end;

	if command_line_start > 0 & cl_sw then do;
	     call complain (0, my_name, "Command line is incompatible with -command_level.");
	     call ERROR_RETURN ();
	end;

	if on_action_specified_sw & existing_txn_policy ^= EXISTING_TXN_NOT_ALLOWED then do;
	     call complain (0, my_name, "-existing_transaction_^[allowed^;required^] is incompatible with ^a",
		existing_txn_policy = EXISTING_TXN_ALLOWED, on_action_name);
	     call ERROR_RETURN ();
	end;

	if txn_existed_sw & existing_txn_policy = EXISTING_TXN_NOT_ALLOWED then do;
	     call complain (0, my_name, "Current transaction already in effect, id = ^w", txn_id);
	     call ERROR_RETURN ();
	end;
	if ^txn_existed_sw & existing_txn_policy = EXISTING_TXN_REQUIRED then do;
	     call complain (0, my_name, "No current transaction, -existing_transaction_required.");
	     call ERROR_RETURN ();
	end;

/* Try to begin a transaction if necessary */

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code = dm_error_$system_not_initialized
	     then go to EXECUTE_BEGIN_ATTEMPTED;
	     else call continue_to_signal_ (0);
	end;

	if ^txn_existed_sw then
	     on cleanup begin;
		call ABORT_OR_ABANDON (txn_id, succeeded_sw);
	     end;

	bj_opening_id = "0"b;

	start_usec = clock ();
	had_to_wait_sw = "0"b;

	do while (^had_to_wait_sw | clock () - start_usec < wait_usec);

	     if txn_existed_sw then code = 0;
	     else call transaction_manager_$begin_txn (TM_NORMAL_MODE, bj_opening_id, txn_id, code);
EXECUTE_BEGIN_ATTEMPTED:
	     if code = 0 then do;
		if had_to_wait_sw then do;
		     call date_time_ (start_usec, requested_time_str);
		     call date_time_ (clock (), begun_time_str);
		     call ioa_ ("Transaction requested at ^a begun ^a", requested_time_str, begun_time_str);
		end;
RETRY:
		call EXECUTE_COMMAND_LINE ();

		if ^txn_existed_sw then do;
		     call transaction_manager_$commit_txn (txn_id, code);
		     if code ^= 0 then do;
			call ABORT_OR_ABANDON (txn_id, succeeded_sw);
			if succeeded_sw then transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
			else transaction_severity_ = FAILED_ABORT_OR_ABANDON_SEVERITY;
			if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
			else call complain (code, my_name, "Unable to commit transaction.");
			call ERROR_RETURN ();
		     end;
		end;
		if retry_count > 0 then do;
		     transaction_severity_ = RETRY_SEVERITY;
		     if ^af_sw then call complain (0, my_name,
			     "^d retries were required to successfully execute the command line.", retry_count);
		end;
		else transaction_severity_ = NO_ERROR_SEVERITY;
		if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
		return;
	     end;
	     else if ^wait_sw | code ^= dm_error_$system_not_initialized then do;
		transaction_severity_ = FATAL_SEVERITY;
		if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
		else call complain (code, my_name, "Could not begin transaction.");
		call ERROR_RETURN ();
	     end;

/* Wait 10 seconds */

	     call timer_manager_$sleep (TEN_SECONDS, RELATIVE_TIME_OPTION);
	     had_to_wait_sw = "1"b;
	end;

	transaction_severity_ = FATAL_SEVERITY;
	if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
	else call complain (0, my_name, "Data Management not available within ^d seconds.", wait_seconds);

	return;
%page;
/* txn kill */
KEY (6):
	if arg_count > 2 then do;
KILL_USAGE:
	     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING ("{transaction_id}"));
	     call ERROR_RETURN ();
	end;

	if arg_count = 2 then do;
	     call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	     if index (arg, "-") = 1 then go to KILL_USAGE;
	     fixed_txn_id = cv_dec_check_ (arg, code);
	     if code ^= 0 then do;
		call complain (code, my_name, "Invalid transaction id ^a", arg);
		call ERROR_RETURN ();
	     end;
	     unspec (txn_id) = unspec (fixed_txn_id);
	end;
	else txn_id = CURRENT_ID ();

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then go to KILL_ATTEMPTED;
	end;

	call transaction_manager_$kill_txn (txn_id, code);
KILL_ATTEMPTED:
	if code ^= 0 then do;
	     if af_sw then return_arg = "false";
	     else call complain (code, my_name);
	end;
	else do;
	     if af_sw then return_arg = "true";
	end;

	return;
%page;
/* txn rollback */
KEY (7):
	if arg_count > 1 then do;
	     call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (""));
	     call ERROR_RETURN ();
	end;

	on sub_error_ begin;
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then go to ROLLBACK_ATTEMPTED;
	end;

	call transaction_manager_$rollback_txn (CURRENT_ID (), INITIAL_CHECKPOINT, code);
ROLLBACK_ATTEMPTED:
	if code ^= 0 then do;
	     if af_sw then return_arg = "false";
	     else call complain (code, my_name);
	end;
	else do;
	     if af_sw then return_arg = "true";
	end;

	return;
%page;
/* txn status */
KEY (8):
	area_ptr = get_system_free_area_ ();
	tix_ptr, tm_info_ptr, txn_info_ptr = null;

	on cleanup call CLEAN_UP_STATUS ();

	tix_bound = arg_count - 1;
	allocate tix in (area) set (tix_ptr);
	tix_count = 0;

	unspec (print_switches), unspec (select_switches) = "0"b;
	multiple_info_sw, total_sw = "0"b;

	do arg_index = 2 to arg_count;

	     call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);

	     if index (arg, "-") ^= 1 then do;
		if af_sw then ctl_args_str = "-control_arg";
		else ctl_args_str = "-control_args";
		call complain_suppress_name (error_table_$too_many_args, my_name, USAGE_STRING (ctl_args_str));
		go to STATUS_RETURN;
	     end;

/* Control args for selecting transactions */

	     if arg = "-abandoned" then
		if af_sw then go to BAD_STATUS_AF_ARG;
		else select_switches.abandoned = "1"b;
	     else if arg = "-all" | arg = "-a" then
		if af_sw then go to BAD_STATUS_AF_ARG;
		else select_switches.all, total_sw = "1"b;
	     else if arg = "-dead" then
		if af_sw then go to BAD_STATUS_AF_ARG;
		else select_switches.dead, select_switches.all = "1"b;
	     else if arg = "-total" | arg = "-tt" then
		if af_sw then go to BAD_STATUS_AF_ARG;
		else total_sw = "1"b;

	     else if arg = "-transaction_id" | arg = "-tid" | arg = "-id" then do;
		if arg_index = arg_count then print_switches.tid = "1"b;
		else do;
		     call cu_$arg_ptr (arg_index + 1, arg_ptr, arg_len, code);
		     if index (arg, "-") = 1 then print_switches.tid = "1"b;
		     else do;			/* -tid N */
			arg_index = arg_index + 1;
			fixed_txn_id = cv_dec_check_ (arg, code);
			if code ^= 0 then do;
			     call complain (code, my_name, "Invalid transaction id ^a", arg);
			     go to STATUS_RETURN;
			end;
			unspec (txn_id) = unspec (fixed_txn_id);
			txn_index = transaction_manager_$get_txn_index (txn_id, code);
			if code ^= 0 then call complain (code, my_name, "transaction id = ^a", arg);
			else do;
			     select_switches.tid = "1"b;
			     tix_count = tix_count + 1;
			     tix (tix_count) = txn_index;
			end;
		     end;
		end;
	     end;

	     else if arg = "-transaction_index" | arg = "-tix" | arg = "-index" then do;
		if arg_index = arg_count then print_switches.tix = "1"b;
		else do;
		     call cu_$arg_ptr (arg_index + 1, arg_ptr, arg_len, code);
		     if index (arg, "-") = 1
		     then print_switches.tix = "1"b;
		     else do;
			arg_index = arg_index + 1;
			txn_index = cv_dec_check_ (arg, code);
			if code ^= 0 then do;
			     call complain (code, my_name, "Invalid transaction index ^a", arg);
			     go to STATUS_RETURN;
			end;
			select_switches.tix = "1"b;
			tix_count = tix_count + 1;
			tix (tix_count) = txn_index;
		     end;
		end;
	     end;

/* Control args for selecting fields to print */

	     else if arg = "-before_journal_path" | arg = "-bj_path" then call REQUEST_INFO (print_switches.bj_path);
	     else if arg = "-begun" | arg = "-date_time_begun" | arg = "-dtbg" then
		call REQUEST_INFO (print_switches.dtm);
	     else if arg = "-error_info" | arg = "-error" then call REQUEST_INFO (print_switches.errors);
	     else if arg = "-owner" then call REQUEST_INFO (print_switches.owner);
	     else if arg = "-process_id" | arg = "-pid" then call REQUEST_INFO (print_switches.pid);
	     else if arg = "-rollback_count" | arg = "-rbc" then call REQUEST_INFO (print_switches.rollback_count);
	     else if arg = "-state" then call REQUEST_INFO (print_switches.state);
	     else if arg = "-switches" | arg = "-switch" | arg = "-sw" then call REQUEST_INFO (print_switches.switches);

	     else do;
BAD_STATUS_AF_ARG:
		call complain (error_table_$badopt, my_name, "^a", arg);
		go to STATUS_RETURN;
	     end;
	end;

	if af_sw & tix_count > 1 then do;
	     call complain (0, my_name, "Can return info for only one transaction.");
	     go to STATUS_RETURN;
	end;

	on sub_error_ begin;			/* eg., DM initialization error */
	     code = SUB_ERROR_CODE ();
	     if code ^= 0 then do;
		call complain (code, my_name);
		go to RETURN;
	     end;
	end;

	if tix_count = 0 & ^select_switches.all & ^total_sw then do;
	     tix_count = tix_count + 1;
	     txn_id = CURRENT_ID ();
	     tix (tix_count) = transaction_manager_$get_txn_index (txn_id, code);
	     if code ^= 0 then do;
		call complain (code, my_name, "transaction id = ^o", fixed (txn_id));
		go to STATUS_RETURN;
	     end;
	end;

	if unspec (print_switches) = "0"b
	then if af_sw then do;
		call complain_suppress_name (error_table_$noarg, my_name, "Usage:  [txn status -control_arg]");
		go to STATUS_RETURN;
	     end;
	     else do;
		unspec (print_switches) = unspec (PRINT_ALL_INFO);
		multiple_info_sw = "1"b;
	     end;

	if select_switches.all | total_sw then
EXAMINE_WHOLE_TDT: do;

	     call transaction_manager_$get_tdt_size (tdt_max_count);
	     if tdt_max_count = 0 then do;
		if af_sw then call complain (0, my_name, "No transactions defined.");
						/* should never happen */
		else call ioa_ ("No transactions defined.");
		go to STATUS_RETURN;
	     end;

	     allocate tm_info in (area) set (tm_info_ptr);
	     allocate txn_info in (area) set (txn_info_ptr);
	     txn_info.version = TXN_INFO_VERSION_5;

	     do tdt_index = 1 to tdt_max_count;
		call transaction_manager_$get_txn_info_index (tdt_index, txn_info_ptr, code);
		if code ^= 0 then do;
		     call complain (code, my_name, "TDT entry #^d", tdt_index);
		     go to STATUS_RETURN;
		end;

		tm_info (tdt_index) = txn_info;
	     end;

/* Print totals if requested */

	     if total_sw then do;

		abandoned_count, dead_count, error_count, txn_count, used_count = 0;
		do tdt_index = 1 to tdt_max_count;
		     if tm_info.owner_process_id (tdt_index) ^= "0"b then used_count = used_count + 1;
		     if DEAD_PROCESS (tm_info.owner_process_id (tdt_index)) then dead_count = dead_count + 1;
		     if tm_info.abandoned_sw (tdt_index) then abandoned_count = abandoned_count + 1;
		     if tm_info.txn_id (tdt_index) ^= "0"b then txn_count = txn_count + 1;
		     if tm_info.error_sw (tdt_index) then error_count = error_count + 1;
		end;

		call ioa_ ("TDT size: ^d entries", tdt_max_count);
		call ioa_ ("In use: ^d", used_count);
		call ioa_ ("Dead processes: ^d", dead_count);
		call ioa_ ("Abandoned entries: ^d", abandoned_count);
		call ioa_ ("Transactions: ^d", txn_count);
		call ioa_ ("Error transactions: ^d", error_count);
		call ioa_ ("");
	     end;

/* Print or return individual transaction information */

	     printed_something_sw = "0"b;
	     if af_sw then return_arg = """""";		/* default value is "" (eg., no txn) */

	     if select_switches.all
	     then do tdt_index = 1 to tdt_max_count;

		if tm_info.owner_process_id (tdt_index) ^= "0"b then do;
		     txn_info = tm_info (tdt_index);
		     call PRINT_ENTRY ();
		end;
	     end;

	     else do tix_index = 1 to tix_count;
		txn_info = tm_info (tix (tix_index));
		call PRINT_ENTRY ();
	     end;

	     if ^printed_something_sw & ^af_sw &
		(select_switches.abandoned | select_switches.dead | select_switches.tid | select_switches.tix) then
		call complain (0, my_name, "No entries with specified attributes.");
	end EXAMINE_WHOLE_TDT;

	else EXAMINE_SPECIFIED_ENTRIES: do;
	     allocate txn_info in (area) set (txn_info_ptr);
	     txn_info.version = TXN_INFO_VERSION_5;

	     do tix_index = 1 to tix_count;
		call transaction_manager_$get_txn_info_index (tix (tix_index), txn_info_ptr, code);
		if code = 0 then call PRINT_ENTRY ();
		else call complain (code, my_name, "TDT entry #^d.", tix (tix_index));
	     end;
	end EXAMINE_SPECIFIED_ENTRIES;
STATUS_RETURN:
	call CLEAN_UP_STATUS ();

	return;
%page;
ABORT_OR_ABANDON: proc (P_txn_id, P_succeeded_sw);

dcl  P_txn_id bit (36) aligned;
dcl  P_succeeded_sw bit (1);
dcl  code fixed bin (35);

	call transaction_manager_$abort_txn (P_txn_id, code);
	if code ^= 0 then do;
	     call transaction_manager_$abandon_txn (P_txn_id, code);
	     if code ^= 0 then do;
		P_succeeded_sw = "0"b;
		call ERROR_RETURN ();
	     end;
	end;
	P_succeeded_sw = "1"b;
	return;

     end ABORT_OR_ABANDON;
%page;
AF_SEVERITY_VALUE: proc (P_severity) returns (char (*));

dcl  P_severity fixed bin;

	if P_severity < 2 then return ("true");
	else return ("false");

     end AF_SEVERITY_VALUE;
%page;
CLEAN_UP_STATUS: proc;

	if tix_ptr ^= null then free tix in (area);
	if tm_info_ptr ^= null then free tm_info in (area);
	if txn_info_ptr ^= null then free txn_info in (area);

     end CLEAN_UP_STATUS;
%page;
CODE_DESCRIPTION: proc (P_code) returns (char (100));

dcl  P_code fixed bin (35);
dcl  message char (100);
dcl  dm_error_$ external bit (36) aligned;
dcl  better_message char (100);
dcl  better_code fixed bin (35);
dcl  pp_as_word bit (36) aligned;
dcl  segno builtin;

%include packed_pointer;

	call convert_status_code_ (P_code, "", message);
	if substr (message, 1, 4) = "Code" then do;	/* Perhaps dm_error_ in another process */
	     pp_as_word = unspec (P_code);
	     packed_pointer_ptr = addr (pp_as_word);
	     packed_pointer.segno = segno (addr (dm_error_$));
	     unspec (better_code) = pp_as_word;
	     call convert_status_code_ (better_code, "", better_message);
	     if substr (better_message, 1, 4) ^= "Code" then message = better_message;
	end;
	return (message);

     end CODE_DESCRIPTION;
%page;
CONDITION_HANDLER: proc (P_txn_id, P_retry_count, P_retry_label);

dcl  P_txn_id bit (36) aligned;
dcl  P_retry_count fixed bin;
dcl  P_retry_label label variable;
dcl  p ptr;
dcl  condition_name char (32);

	if handler_invoked_sw then do;
	     call continue_to_signal_ (0);
	     handler_invoked_sw = "0"b;
	     return;
	end;
	handler_invoked_sw = "1"b;

	if first_handler_ptr = null then return;	/* no handler for any condition */

	call find_condition_info_ (null, addr (cond_info), code);
	if code ^= 0 then condition_name = "any_other";	/* can't get name, trigger the any_other handler */
	else condition_name = cond_info.condition_name;

/* Try the specific condition name */

	do p = first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
	     if p -> handler_node.condition_name = condition_name then do;
		call do_action (p, P_txn_id, P_retry_count, P_retry_label);
		return;
	     end;
	end;

/* That having failed, look for an any_other handler */

	do p = first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
	     if p -> handler_node.condition_name = "any_other" then do;
		call do_action (p, P_txn_id, P_retry_count, P_retry_label);
		return;
	     end;
	end;

	handler_invoked_sw = "0"b;

	return;


do_action: proc (P_ptr, P_txn_id, P_retry_count, P_retry_label);

dcl  P_ptr ptr;
dcl  P_txn_id bit (36) aligned;
dcl  (P_retry_count, action) fixed bin;
dcl  code fixed bin (35);
dcl  P_retry_label label variable;

	action = P_ptr -> handler_node.action;
	if action = ABANDON_ACTION then do;
	     call transaction_manager_$abandon_txn (P_txn_id, code);
	     if code ^= 0 then transaction_severity_ = FAILED_ABORT_OR_ABANDON_SEVERITY;
	     else transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
	     if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
	     else call complain (0, my_name,
		     "Abandoning the command line and its transaction because the ^a condition was signaled.",
		     P_ptr -> handler_node.condition_name);
	     goto RETURN;
	end;
	else if action = ABORT_ACTION then do;
	     call transaction_manager_$abort_txn (P_txn_id, code);
	     if code ^= 0 then transaction_severity_ = FAILED_ABORT_OR_ABANDON_SEVERITY;
	     else transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
	     if af_sw then return_arg = AF_SEVERITY_VALUE (transaction_severity_);
	     else call complain (0, my_name,
		     "Aborting the command line and its transaction because the ^a condition was signaled.",
		     P_ptr -> handler_node.condition_name);
	     goto RETURN;
	end;
	else if action = NO_ACTION then ;
	else if action = RETRY_ACTION then do;
	     P_retry_count = P_retry_count + 1;
	     if P_retry_count > p -> handler_node.retry_limit then return;
	     else go to P_retry_label;
	end;
	else if action = SUSPEND_ACTION then do;
	     call transaction_manager_$handle_conditions ();
	     handler_invoked_sw = "0"b;
	end;

     end do_action;

     end CONDITION_HANDLER;
%page;
CURRENT_ID: proc returns (bit (36) aligned);

dcl  txn_id bit (36) aligned;
dcl  tried_resume_sw bit (1);
dcl  code fixed bin (35);

	tried_resume_sw = "0"b;
GET_ID:
	call transaction_manager_$get_current_txn_id (txn_id, code);
	if code ^= 0 then do;
	     if code = dm_error_$transaction_suspended & ^tried_resume_sw then
		if my_name = "txn status" then return (txn_id);
		else if my_name = "txn abandon" | my_name = "txn abort" then do;
		     tried_resume_sw = "1"b;
		     code = 0;
		     call transaction_manager_$resume_txn (code);
		     if code ^= 0 then do;
			if af_sw then return_arg = "false";
			else call complain (code, my_name, "Could not resume transaction.");
			go to RETURN;
		     end;
		     else go to GET_ID;
		end;
	     if txn_id = "0"b then do;
		if af_sw then return_arg = "false";
		else call complain (code, my_name);
		go to RETURN;
	     end;
	end;
	return (txn_id);

     end CURRENT_ID;
%page;
DEAD_PROCESS: proc (P_process_id) returns (bit (1));

dcl  P_process_id bit (36) aligned;
dcl  code fixed bin (35);

	if P_process_id = "0"b then return ("0"b);

	call hcs_$validate_processid (P_process_id, code);
	return (code ^= 0);

     end DEAD_PROCESS;
%page;
ERROR_RETURN: proc;

	go to RETURN;

     end ERROR_RETURN;
%page;
EXECUTE_COMMAND_LINE: proc;

dcl  line_len fixed bin (21);
dcl  arg_index fixed bin;

	if command_line_start > 0 then do;
	     line_len = -1;
	     do arg_index
		= command_line_start to arg_count;
		call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, 0, alp);
		line_len = line_len + arg_len + 1;
	     end;
	     begin;
dcl  line char (line_len);

		line = "";
		line_len = -1;
		do arg_index = command_line_start to arg_count;
		     call cu_$arg_ptr_rel (arg_index, arg_ptr, arg_len, 0, alp);
		     substr (line, line_len + 2, arg_len) = arg;
		     line_len = line_len + arg_len + 1;
		end;

		handler_invoked_sw = "0"b;
		on any_other begin;
		     call CONDITION_HANDLER (txn_id, retry_count, RETRY);
		end;

		call cu_$cp (addr (line), line_len, code);
		if code ^= 0 then transaction_severity_ = ABORT_OR_ABANDON_SEVERITY; /* Is this right? */
	     end;
	end;

	else do;
	     begin;
dcl  var_line char (3000) varying;
dcl  1 qi aligned like query_info;

		unspec (qi) = "0"b;
		qi.version = query_info_version_5;
		qi.question_iocbp, qi.answer_iocbp, qi.explanation_ptr = null;
		qi.suppress_name_sw = "1"b;

		call command_query_ (addr (qi), var_line, "transaction execute", "Command line:");

		handler_invoked_sw = "0"b;
		on any_other begin;
		     call CONDITION_HANDLER (txn_id, retry_count, RETRY);
		end;

		call cu_$cp (addrel (addr (var_line), 1), length (var_line), code);
		if code ^= 0 then transaction_severity_ = ABORT_OR_ABANDON_SEVERITY;
	     end;
	end;

     end EXECUTE_COMMAND_LINE;
%page;
GET_CONDITION_LIST: proc (P_name, P_index, P_action, P_retry_limit);

dcl  P_name char (*);
dcl  (P_index, P_action, P_retry_limit, comma_pos, list_pos) fixed bin;
dcl  condition_name char (32);
dcl  COMMA char (1) int static options (constant) init (",");

	P_index = P_index + 1;
	if P_index > arg_count then do;
	     call complain (0, my_name, "No condition list specified for ^a", P_name);
	     go to RETURN;
	end;
	call cu_$arg_ptr_rel (P_index, arg_ptr, arg_len, code, alp);

	list_pos = 1;
	do while (list_pos <= arg_len);

	     comma_pos = verify (substr (arg, list_pos), COMMA);
	     if comma_pos = 0 then return;

	     list_pos = list_pos + comma_pos - 1;
	     comma_pos = index (substr (arg, list_pos), COMMA);
	     if comma_pos = 0 then do;
		condition_name = substr (arg, list_pos);
		list_pos = arg_len + 1;
	     end;
	     else do;
		condition_name = substr (arg, list_pos, comma_pos - 1);
		list_pos = list_pos + comma_pos;
	     end;

	     call SAVE_HANDLER (condition_name, P_action, P_retry_limit);
	end;

	return;

     end GET_CONDITION_LIST;
%page;
PRINT_ENTRY: proc ();

dcl  (buffer, dn) char (168);
dcl  state_description_buffer char (68);
dcl  (en, time_string) char (32);

	if txn_info.owner_process_id = "0"b then do;
	     if af_sw & print_switches.pid then return_arg = "0";
	     return;
	end;

	if select_switches.abandoned & ^txn_info.abandoned_sw then do;
	     if ^select_switches.dead | ^DEAD_PROCESS (txn_info.owner_process_id) then return;
	end;
	else if select_switches.dead & ^DEAD_PROCESS (txn_info.owner_process_id) then return;

	printed_something_sw = "1"b;

	txn_exists_sw = (txn_info.txn_id ^= "0"b);
	print_no_txn_warning_sw = "0"b;

	if print_switches.tix then call PRINT_ITEM ("Transaction index", character (txn_info.txn_index), ENTRY_ITEM);
	if print_switches.tid then
	     call PRINT_ITEM ("Transaction id", character (fixed (txn_info.txn_id)), TXN_ITEM);
	if print_switches.pid then do;
	     call ioa_$rsnnl ("^w^[ (dead)^]", buffer, length (buffer), txn_info.owner_process_id,
		DEAD_PROCESS (txn_info.owner_process_id) & ^af_sw);
	     call PRINT_ITEM ("Process id", buffer, ENTRY_ITEM);
	end;
	if print_switches.owner then call PRINT_ITEM ("Owner", (txn_info.owner_name), ENTRY_ITEM);
	if print_switches.dtm then do;
	     if txn_info.date_time_created = 0
	     then time_string = "(undefined)";
	     else call date_time_ (txn_info.date_time_created, time_string);
	     call PRINT_ITEM ("Begun at", time_string, TXN_ITEM);
	end;
	if print_switches.state then do;
	     state_description_buffer = transaction_manager_$get_state_description (txn_info.state);
	     call PRINT_ITEM ("State", state_description_buffer, TXN_ITEM);
	end;
	if print_switches.errors then
	     if ^txn_info.error_sw then call PRINT_ITEM ("Error", "none", TXN_ITEM);
	     else call PRINT_ITEM ("Error", CODE_DESCRIPTION (txn_info.error_code), TXN_ITEM);
	if print_switches.rollback_count then
	     call PRINT_ITEM ("Rollback count", character (txn_info.rollback_count), TXN_ITEM);
	if print_switches.bj_path then do;
	     if txn_info.bj_uid = "0"b then
		if af_sw then return_arg = "";
		else call ioa_ ("No before journal.");
	     else do;
		if txn_info.owner_process_id = get_process_id_ () then
		     call before_journal_manager_$get_bj_path_from_oid (txn_info.bj_oid, dn, en, code);
		else call before_journal_manager_$get_bj_path_from_uid (txn_info.bj_uid, dn, en, code);
		if code ^= 0 then
		     call complain (code, my_name, "Before journal uid = ^w", txn_info.bj_uid);
		else call PRINT_ITEM ("Before journal path", pathname_ (dn, en), TXN_ITEM);
	     end;
	end;
	if print_switches.switches then do;
	     if unspec (txn_info.flags) = "0"b then buffer = "none";
	     else do;
		buffer = "";
		if txn_info.abandoned_sw then buffer = "ABANDONED";
		if txn_info.kill_sw then call append ("KILL");
		if txn_info.suspended_sw then call append ("SUSPENDED");
		if txn_info.dead_process_sw then call append ("DEAD_PROCESS");
	     end;
	     call PRINT_ITEM ("Switches", buffer, TXN_ITEM);
	end;

	if print_no_txn_warning_sw then call ioa_ ("No transaction.");

	if multiple_info_sw & ^af_sw then call ioa_ (""); /* separate blocks of info */

append: proc (P_str);

dcl  P_str char (*);

	if buffer ^= "" then buffer = rtrim (buffer) || ",";
	buffer = rtrim (buffer) || P_str;

     end append;

     end PRINT_ENTRY;
%page;
PRINT_ITEM: proc (P_name, P_value, P_item_type);

dcl  (P_name, P_value) char (*);
dcl  P_item_type fixed bin;

	if af_sw then do;
	     if txn_exists_sw | P_item_type = ENTRY_ITEM then return_arg = ltrim (rtrim (P_value));
	end;

	else if ^txn_exists_sw & P_item_type = TXN_ITEM then print_no_txn_warning_sw = "1"b;

	else if multiple_info_sw then call ioa_ ("^a: ^a", P_name, ltrim (rtrim (P_value)));
	else call ioa_ ("^a", ltrim (rtrim (P_value)));

     end PRINT_ITEM;
%page;
REQUEST_INFO: proc (P_sw);

dcl  P_sw bit (1) unaligned;

	P_sw = "0"b;				/* to test if others on */
	if unspec (print_switches) ^= "0"b then do;
	     if af_sw then do;
		call complain (0, my_name, "Can only return one item of information.");
		go to RETURN;
	     end;
	     multiple_info_sw = "1"b;
	end;

	P_sw = "1"b;

	return;

     end REQUEST_INFO;
%page;
SAVE_HANDLER: proc (P_condition_name, P_action, P_retry_limit);

dcl  P_condition_name char (*);
dcl  (P_action, P_retry_limit) fixed bin;
dcl  (p, last_p) ptr;

	if first_handler_ptr = null then do;
	     allocate handler_node in (area) set (p);
	     first_handler_ptr = p;
FILL_NEW_NODE:
	     p -> handler_node.next_ptr = null;
	     p -> handler_node.condition_name = P_condition_name;
FILL_NODE:
	     p -> handler_node.action = P_action;
	     p -> handler_node.retry_limit = P_retry_limit;
	     return;
	end;
	do p = first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
	     if p -> handler_node.condition_name = P_condition_name then go to FILL_NODE;
	     last_p = p;
	end;
	allocate handler_node in (area) set (p);
	last_p -> handler_node.next_ptr = p;
	go to FILL_NEW_NODE;

     end SAVE_HANDLER;
%page;
SUB_ERROR_CODE: proc returns (fixed bin (35));

	call find_condition_info_ (null, addr (cond_info), code);
	if code ^= 0 then return (dm_error_$system_not_initialized);

	if cond_info.info_ptr -> sub_error_info.default_restart then do;
						/* a warning */
	     call continue_to_signal_ (0);
	     return (0);
	end;

	else return (cond_info.info_ptr -> sub_error_info.retval);

     end SUB_ERROR_CODE;
%page;
USAGE_STRING: proc (P_str) returns (char (128));

dcl  P_str char (*);
dcl  buffer char (128) varying;

	buffer = "Usage:  " || rtrim (my_name);
	if P_str ^= "" then buffer = buffer || " " || P_str;
	if af_sw
	then return ("[" || buffer || "]");
	else return (buffer);

     end USAGE_STRING;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include dm_tm_modes;
%page;
%include dm_tm_txn_info;
%page;
%include query_info;
%page;
%include sub_error_info;


     end transaction;




		    transaction_manager_.alm        04/24/85  1016.3re  04/24/85  0803.3       57123



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
"
"
" DESCRIPTION:
"	 This is the main transfer vector for transaction manager
"    primitives.  Note the abnormality with the user_shutdown and
"    user_shutdown_real entries, this is caused by the necessity of
"    running user shutdown in the DM ring.
"
"
" HISTORY:
"
" Written by Steve Herbst, 08/10/82.
" Modified:
" 08/16/82 by S. Herbst:  added per_process_init and per_system_init, and
"	    deleted create_tdt.
" 08/27/82 by S. Herbst:  added terminate_proc, recover, and rollback_txn.
" 10/14/82 by S. Herbst:  added adjust_txn and recover_after_crash.
" 11/05/82 by S. Herbst:  added adjust_tdt, suspend_txn, resume_txn.
" 11/08/82 by S. Herbst:  deleted pop_current_txn, priv_abort_txn,
"	    priv_push_current_txn, push_current_txn, recover.
" 11/08/82 by S. Herbst:  added adjust_process_id.
" 11/15/82 by S. Herbst:  added log_errors, deleted terminate_proc.
" 01/10/83 by S. Herbst:  added handle_conditions.
" 01/19/83 by S. Herbst:  added abandon_txn & kill_txn.
" 01/25/83 by Jeffrey D. Ives:  modified to call tm_gate_.
" 03/23/83 by S. Herbst:  added begins_off, begins_on.
" 04/06/83 by S. Herbst:  added get_txn_index, needed by lock_manager_.
" 04/19/83 by Jeffrey D. Ives:  changed from tra to call6 so that gates work.
" 04/20/83 by S. Herbst:  added get_tdt_size & get_txn_info_index for use
"	    by txn_status command.
" 05/11/83 by S. Herbst:  added adjust_txn, called by user to send msg to
"	    daemon to adjust.
" 05/27/83 by S. Herbst:  added get_current_ids.
" 06/06/83 by S. Herbst:  changed $handle_conditions to call
"	    tm_handle_conditions directly in user ring.
" 07/29/83 by Lindsey Spratt:  changed $handle_conditions to call
"	    tm_handle_conditions through tm_inner_ring_tv_.
" 08/05/83 by Lindsey Spratt:  changed reference to
"	    tm_inner_ring_tv_$handle_conditions rather than
"	    $tm_handle_conditions.
" 09/09/83 by Lee A. Newcomb:  removed obs. per_process_init entry &
"	    made per_system_init not go through tm_gate_.
" 09/15/83 by L. A. Newcomb:  changed $handle_conditions to call
"	    tm_handle_conditions directly, it is supposed to be
"	    called in ***** the user's ring of execution. *****
" 01/04/84 by L. A. Newcomb:  changed tm_gate_ to dm_gate_ or dm_daemon_gate_,
"	    as required by function (one gate saves segno's).  In the
"	    process of this, simplified the transfer macro.
" 01/27/84 by S. Herbst:  added get_state_description, user_shutdown.
" 03/16/84 by S. Herbst:  made get_state_description call tm_... directly.
" 03/27/84 by L. A. Newcomb:  add get_state_info, made two macros, one for
"	    gate calls and one that just tra's to the target entry, 
"	    and changed user_shutdown to not use dm_gate_.
" 05/02/84 by Lee A. newcomb:  added user_shutdown, user_shutdown_free,
"	    user_shutdown_adjust, and user_shutdown_real entries.  Added
"	    transfer_no_prefix macro for calling tm_inner_ring_tv_.
" 05/31/84 by Lindsey Spratt:  Fixed user_shutdown_real to not transfer to the
"	    tm_inner_ring_tv_, but to transfer directly to
"	    tm_user_shutdown_real (renamed from tm_user_shutdown).
" 07/31/84 by S. Herbst:  Added $dm_system_in_use entry.
" 08/08/84 by Lee A. Newcomb:  Added $ips_wakeup entry.
" 10/01/84 by Lee A. Newcomb:  Added $ips_wakeup_all entry.
" 11/22/84 by Lee A. Newcomb:  Re-added $per_process_init as part of
"	    fixing the DMS firstref.
" 12/02/84 by Stanford S. Cox: Chg *inner_ring_tv_ to =firstref_tv_
" 12/06/84 by R. Michael Tague: Added $bump_all
" 04/17/85 by Lee A. Newcomb:  Changed $user_shutdown to directly call its
"             target in the user ring and $user_shutdown_real to gate.
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	name	transaction_manager_

"
"  Macros to generate call to tm*  entries:
"	Most target entries in this TV  have a tm_ prefix and so the
"	gate_transfer and transfer macros put it on for the user.  Those
"	entries whose target entry in is tm_firstref_tv_ will use the
"	transfer_no_prefix macro.  The gate_transfer macro is the most
"	used as most of the transaction_manager_ entries are supposed to
"	be able to cross rings  the transfer and transfer_no_prefix
"	macros are for those few entries that do not do ring crossing
"	(e.g., the table lookup entry get_state_description).  Other
"	macros can be easily be created later to use a different naming
"	protocol, if necessary.
"
	macro	gate_transfer
	entry	&1
&1:	call6	&2$tm_&1
	&end

	macro	transfer
	entry	&1
&1:	tra	&2$tm_&1
	&end

	macro	transfer_no_prefix
	entry	&1
&1:	tra	&2$&1
	&end

	gate_transfer	abandon_txn,dm_gate_

	gate_transfer	abort_txn,dm_gate_

	gate_transfer	adjust_process_id,dm_daemon_gate_

	gate_transfer	adjust_tdt,dm_gate_

	gate_transfer	adjust_tdt_entry,dm_daemon_gate_

	gate_transfer	adjust_txn,dm_gate_

	gate_transfer	begin_txn,dm_gate_

	gate_transfer	begins_off,dm_daemon_gate_

	gate_transfer	begins_on,dm_daemon_gate_

	gate_transfer	bump_all,dm_daemon_gate_

	gate_transfer	commit_txn,dm_gate_

	gate_transfer	dm_system_in_use,dm_daemon_gate_

	gate_transfer	get_current_ids,dm_gate_

	gate_transfer	get_current_txn_id,dm_gate_

	transfer		get_state_description,tm_get_state_description

	transfer		get_state_info,tm_get_state_info

	gate_transfer	get_tdt_size,dm_gate_

	gate_transfer	get_txn_index,dm_gate_

	gate_transfer	get_txn_info,dm_gate_

	gate_transfer	get_txn_info_index,dm_gate_

	transfer		handle_conditions,tm_handle_conditions

	gate_transfer	ips_wakeup,dm_daemon_gate_

	gate_transfer	ips_wakeup_all,dm_daemon_gate_

	gate_transfer	kill_txn,dm_daemon_gate_

	transfer_no_prefix	per_process_init,tm_firstref_tv_

	transfer		per_system_init,tm_per_system_init

	gate_transfer	recover_after_crash,dm_daemon_gate_

	gate_transfer	resume_txn,dm_gate_

	gate_transfer	rollback_txn,dm_gate_

	gate_transfer	suspend_txn,dm_gate_

	transfer		user_shutdown,tm_user_shutdown

	transfer_no_prefix	user_shutdown_adjust,tm_firstref_tv_

	transfer_no_prefix	user_shutdown_free,tm_firstref_tv_

	gate_transfer	user_shutdown_real,dm_gate_

	end


*/
                                          -----------------------------------------------------------


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

*/
