



		    log_create_.pl1                 11/11/89  1059.9r w 11/11/89  0802.0       72108



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

/* *	LOG_CREATE_
   *
   *	This procedure is used primarily to create log segments. It is the
   *	major maintainer of the log_segment_info structure, and therefore
   *	also has an entrypoint for filling in such a structure.
   *
   *	Modification history:
   *	1984-06-02, W. Olin Sibert: Initial coding
   *	1984-12-20, WOS: Added mode values to segment_info structure
   *	1984-12-21, WOS: Changed to give better message for link entries
   *	1984-12-27, Keith Loepere: Modified for version 2 create_branch_info
   */

declare	P_log_segment_info_ptr pointer parameter;
declare	P_old_log_ptr pointer parameter;
declare	P_new_log_ptr pointer parameter;
declare	P_log_dname char (*) parameter;
declare	P_log_ename char (*) parameter;
declare	P_code fixed bin (35) parameter;

declare	code fixed bin (35);
declare	old_log_dname char (168);

declare   error_table_$link fixed bin (35) external static;
declare   error_table_$namedup fixed bin (35) external static;

declare	get_system_free_area_ entry () returns (pointer);
declare	get_group_id_$tag_star entry () returns (char (32));
declare	hcs_$create_branch_ entry (char (*), char (*), pointer, fixed bin (35));
declare	hcs_$fs_get_path_name entry (pointer, char (*), fixed bin, char (*), fixed bin (35));
declare	hcs_$get_max_length_seg entry (pointer, fixed bin (19), fixed bin (35));
declare	hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), pointer, fixed bin (35));
declare	hcs_$list_acl entry (char (*), char (*), pointer, pointer, pointer, fixed bin, fixed bin (35));
declare	hcs_$replace_acl entry (char (*), char (*), pointer, fixed bin, bit (1) aligned, fixed bin (35));
declare	hcs_$set_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35));
declare	hcs_$status_for_backup entry (char (*), char (*), pointer, fixed bin (35));
declare	hcs_$status_long entry (char (*), char (*), fixed bin (1), pointer, pointer, fixed bin (35));
declare   hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
declare	log_initialize_ entry (pointer, pointer, fixed bin (19), char (*), fixed bin (35));

declare  (addr, null, substr, unspec) builtin;

/* */

/* This entrypoint just fills in a log_segment_info structure to describe the
   segment specified. This is used wby log_write_. */

log_create_$get_info:
     entry (P_log_segment_info_ptr, P_old_log_ptr, P_code);

	log_segment_info_ptr = P_log_segment_info_ptr;

	call get_log_status (P_old_log_ptr);
	call finished (0);




/* This entrypoint is used to create a brand new log segment, for which there 
   is no existing segment to copy. The caller must have completely filled in 
   the log_segment_info structure before calling this entrypoint.
   */

log_create_$new_segment:
     entry (P_log_segment_info_ptr, P_new_log_ptr, P_code);

	log_segment_info_ptr = P_log_segment_info_ptr;

	call make_log_segment (null (), "", P_new_log_ptr);
	call finished (0);

/* */

/* This entrypoint is used to duplicate an existing log segment. It copies
   all the attributes of the old segment onto the new one. The dname and
   ename are separately supplied for the new log, since of course we don't
   want to end up tryng to create the same segment over again. */

log_create_$duplicate_segment:
     entry (P_log_segment_info_ptr, P_log_dname, P_log_ename, P_old_log_ptr, P_new_log_ptr, P_code);

	log_segment_info_ptr = P_log_segment_info_ptr;

	call get_log_status (P_old_log_ptr);

/* Now, extract the old pathname and insert the new one */

	old_log_dname = log_segment_info.dname;

	log_segment_info.dname = P_log_dname;
	log_segment_info.ename = P_log_ename;

	call make_log_segment (P_old_log_ptr, old_log_dname, P_new_log_ptr);
	call finished (0);

/* */

get_log_status:
     procedure (P_log_ptr);

declare	P_log_ptr pointer parameter;

declare	log_dname char (168);
declare	log_ename char (32);
declare	log_max_lth fixed bin (19);
declare 1 sfb aligned like status_for_backup automatic;
declare 1 status aligned like status_branch automatic;


	call hcs_$fs_get_path_name (P_log_ptr, log_dname, (0), log_ename, code);
	call check_code ();

	sfb.version = status_for_backup_version_2;
	call hcs_$status_for_backup (log_dname, log_ename, addr (sfb), code);
	call check_code ();

	call hcs_$status_long (log_dname, log_ename, 1, addr (status), null (), code);
	call check_code ();

	call hcs_$list_acl (log_dname, log_ename, (get_system_free_area_ ()),
	     log_segment_info.acl_ptr, null (), log_segment_info.acl_count, code);
	call check_code ();

	call hcs_$get_max_length_seg (P_log_ptr, log_max_lth, code);
	call check_code ();

	log_segment_info.rings (*) = status.ring_brackets (*);
	log_segment_info.max_length = log_max_lth;	/* Not sfb.max_length, which is always 261120 */
	log_segment_info.multi_class = sfb.multiple_class;
	log_segment_info.access_class = sfb.access_class;

/* NOTE: This depends on the format of the old 5-bit mode values, usually
   seen as fixed bin (5) values. */

	log_segment_info.effective_mode = substr (status.mode, 2, 3);

	log_segment_info.dname = log_dname;
	log_segment_info.ename = log_ename;

	return;
	end get_log_status;

/* */

make_log_segment:
     procedure (P_old_log_ptr, P_old_log_dname, P_new_log_ptr);

declare	P_old_log_ptr pointer parameter;
declare	P_old_log_dname char (168) parameter;
declare	P_new_log_ptr pointer parameter;

declare	log_ptr pointer;
declare   entry_type fixed bin (2);

declare 1 cbi aligned like create_branch_info automatic;


	P_new_log_ptr = null ();

	unspec (cbi) = ""b;
	cbi.mode = RW_ACCESS;
	cbi.bitcnt = 36 * log_segment_info.max_length;
	cbi.access_class = log_segment_info.access_class;
	cbi.priv_upgrade_sw = log_segment_info.multi_class;
	cbi.rings (*) = log_segment_info.rings (*);
	cbi.userid = get_group_id_$tag_star ();
	cbi.version = create_branch_version_2;

	call hcs_$create_branch_ (log_segment_info.dname, log_segment_info.ename, addr (cbi), code);
	if (code = error_table_$namedup) then do;	/* Special-case error message for links */
	     entry_type = -1;			/* Initialize in case status_minf fails */
	     call hcs_$status_minf (log_segment_info.dname, log_segment_info.ename, 0, entry_type, (0), (0));
	     if (entry_type = 0) then			/* Link type */
		code = error_table_$link;
	     end;

	call check_code ();

	call hcs_$set_max_length (log_segment_info.dname, log_segment_info.ename, log_segment_info.max_length, (0));

	if (log_segment_info.acl_ptr ^= null ()) & (log_segment_info.acl_count ^= 0) then
	     call hcs_$replace_acl (log_segment_info.dname, log_segment_info.ename,
		log_segment_info.acl_ptr, log_segment_info.acl_count, "0"b, (0));

	call hcs_$initiate (log_segment_info.dname, log_segment_info.ename, "", 0, 0, log_ptr, code);
	if (log_ptr ^= null ()) then code = 0;
	call check_code ();

	call log_initialize_ (P_old_log_ptr, log_ptr, log_segment_info.max_length, P_old_log_dname, code);
	call check_code ();

	P_new_log_ptr = log_ptr;

	return;
	end make_log_segment;

/* */

check_code:
     procedure ();

	if (code = 0) then return;

	call finished (code);

	end check_code;



finished:
     procedure (P_return_code);

declare	P_return_code fixed bin (35) parameter;


	P_code = P_return_code;
	goto MAIN_RETURN;

	end finished;



MAIN_RETURN:
	return;

%page; %include log_write_data;
%page; %include status_for_backup;
%page; %include status_structures;
%page; %include create_branch_info;
%page; %include access_mode_values;

	end log_create_;




		    log_initiate_.pl1               11/11/89  1059.9r w 11/11/89  0802.0       30951



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
log_initiate_:
     procedure (P_dname, P_ename, P_max_tries, P_log_segment_ptr, P_code);

/* *	LOG_INITIATE_
   *
   *	This procedure is the user-ring log initiation procedure. It 
   *	attempts to initiate the log segment, and sleeps for a second 
   *	if it can't do it, or if the log segment appears to be 
   *	uninitialized. The one-second wait is repeated P_max_tries 
   *	times, at which point it gives up.
   *
   *	Modification history:
   *	1984-05-04, W. Olin Sibert: after Benson's log_mgr_
   *	1984-12-21, WOS: Changed to return pointer when log not initilized
   */

declare	P_dname char (*) parameter;
declare	P_ename char (*) parameter;
declare	P_max_tries fixed bin parameter;
declare	P_log_segment_ptr pointer parameter;
declare	P_code fixed bin (35) parameter;

declare	retry_count fixed bin;
declare	code fixed bin (35);

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

declare	hcs_$terminate_noname entry (pointer, fixed bin (35));
declare	initiate_file_ entry (char (*), char (*), bit (*), pointer, fixed bin (24), fixed bin (35));
declare	timer_manager_$sleep entry (fixed bin (71), bit (2));

declare	RELATIVE_MICROSECONDS bit (2) internal static options (constant) init ("10"b);
declare	ONE_QUARTER_SECOND fixed bin (71) internal static options (constant) init (250000);

declare	cleanup condition;

declare	null builtin;

/* */

	log_segment_ptr = null ();
	P_log_segment_ptr = null ();

	on condition (cleanup) begin;			/* The cleanup handler is particularly important because */
	     if (log_segment_ptr ^= null ()) then		/* this procedure can wait for a long time */
		call hcs_$terminate_noname (log_segment_ptr, (0));
	     end;

	call initiate_file_ (P_dname, P_ename, R_ACCESS, log_segment_ptr, (0), code);
	if (code ^= 0) then call finished (code);

/* Now we waits for the log segment header to be initialized. If log_initiate_
   gets called at all, the assumption is that some other process has already
   initialized, or is initializing, the log segment, and all we must do is
   wait a bit. If we have to initialize it ourselves, we would have called
   log_create_, instead. */

	do retry_count = 1 to P_max_tries;
	     if (log_segment.version = LOG_SEGMENT_VERSION_1) then do;
		P_log_segment_ptr = log_segment_ptr;
		call finished (0);
		end;

	     if (retry_count < P_max_tries) then	/* Don't wait if we won't have another chance */
		call timer_manager_$sleep (ONE_QUARTER_SECOND, RELATIVE_MICROSECONDS);
	     end;

/* It didn't get initialized in time. Terminate it, and give up. */

	P_log_segment_ptr = log_segment_ptr;
	call finished (error_table_$log_uninitialized);

/* */

finished:
     procedure (P_return_code);

declare	P_return_code fixed bin (35) parameter;


	P_code = P_return_code;
	goto MAIN_RETURN;

	end finished;



MAIN_RETURN:					/* Only exit from this program */
	return;

%page; %include access_mode_values;
%page; %include log_segment;

	end log_initiate_;




		    log_list_history_.pl1           11/11/89  1059.9r   11/11/89  0800.0      151371



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

/* format: style4 */

log_list_history_:
     procedure ();

/* *	LOG_LIST_HISTORY_
   *
   *	This procedure is responsible for allocating and filling in a log_read_data
   *	structure containing the pathnames of all the logs it can find in the chain
   *	of history begun in the first log. All the logs from each separate directory
   *	in the history are sorted in chronological order (by name), and space is
   *	left at the beginning of the log_read_data array for the initial log
   *	(or logs). This procedure is a utility, used only by log_read_$open.
   *
   *	It has one minor problem: it cannot handle the case of looping history
   *	directories, where log_A points to log_B which points back to log_A.
   *	There are various ways in which this could be remedied, and one should
   *	be chosen eventually. Log unique-id comparison is probably the best
   *	choice, but, as such, should include the initial log(s), and therefore
   *	must be handled outside this procedure.
   *
   *	84-05-04, W. Olin Sibert: In celebration of recursion
   *	84-08-25, WOS: Added $single_dir entrypoint for log_write_ migration
   *	84-10-16, WOS: Converted to use log_name_$starname
   *    1984-12-15, BIM: version sentinel in log_read_data_.
   *	85-03-03, EJ Sharpe: Changed single_dir entry to return log_read_data structure, added format,
   *		added single_dir_oldest_and_newest to replace old functionality of single_dir,
*/

declare  P_first_log_ptr pointer parameter;
declare  P_log_name char (*) parameter;
declare  P_initial_count fixed bin parameter;
declare  P_log_read_data_ptr pointer parameter;
declare  P_log_dname char (*) parameter;
declare  P_oldest_log_name char (*) parameter;
declare  P_newest_log_name char (*) parameter;
declare  P_log_count fixed bin parameter;
declare  P_code fixed bin (35) parameter;

declare  code fixed bin (35);

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

declare  total_segment_count fixed bin;
declare  last_segment_entered fixed bin;
declare  log_starname char (32);

declare  first_log_ptr pointer;
declare  first_dname char (168);
declare  first_uid bit (36) aligned;

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

declare  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
declare  get_system_free_area_ entry () returns (pointer);
declare  hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35));
declare  hcs_$star_ entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35));
declare  log_initiate_ entry (char (*), char (*), fixed bin, pointer, fixed bin (35));
declare  log_name_$starname entry (char (*)) returns (char (32));
declare  log_name_$time entry (char (*)) returns (fixed bin (71));
declare  sort_items_$general entry (pointer, entry);


declare  cleanup condition;

declare  (addr, null, sum) builtin;
%page;

log_list_history_$all:
     entry (P_first_log_ptr, P_log_name, P_initial_count, P_log_read_data_ptr);

	total_segment_count = P_initial_count;		/* Enough to start with-- as many as our caller has */
	first_log_ptr = P_first_log_ptr;

/* Starname matches LogName.YYYYMMDD.HHMMSS */

	log_starname = log_name_$starname (P_log_name);

	system_area_ptr = get_system_free_area_ ();

/* See if the first log we got points back to anything at all. If it doesn't, then
   we just allocate a small return structure and return. Otherwise, we start by
   listing the first history directory, and begin recursing. One of those recursive
   calls will give up and allocate the return structure, so by the time the call
   to list_log_directory returns, all will be ready and filled in. */

	if ^get_dname_and_uid (first_log_ptr, first_dname, first_uid) then
	     call allocate_read_data ();
	else call list_log_directory (first_dname, first_uid, "1"b);

	P_log_read_data_ptr = log_read_data_ptr;	/* Return the structure we allocated */
	return;
%page;

log_list_history_$single_dir:
     entry (P_log_dname, P_log_name, P_log_read_data_ptr, P_code);

/* This entrypoint returns a log_read_data structure with information about only
   the logs in a single history directory. */

	first_dname = P_log_dname;
	log_starname = log_name_$starname (P_log_name);

	total_segment_count = 0;
	log_read_data_ptr = null ();
	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) begin;
	     if (log_read_data_ptr ^= null ()) then
		free log_read_data_ptr -> log_read_data in (system_area);
	end;

	call hcs_$get_uid_file (first_dname, "", first_uid, code); /* We need this value as a parameter, and, in */
	if (code ^= 0) then do;			/* any case, this is a good place to fail if noentry */
	     P_code = code;
	     return;
	end;

	call list_log_directory (first_dname, first_uid, "0"b); /* Just this directory, please */

	P_log_read_data_ptr = log_read_data_ptr;
	P_code = 0;

	return;
%page;

log_list_history_$single_dir_oldest_and_newest:
     entry (P_log_dname, P_log_name, P_oldest_log_name, P_newest_log_name, P_log_count, P_code);

/* This entrypoint is used (by log_write_$open_for_migrate) to determine the names
   of the oldest and newest log segments in a particular log directory.  Rather
   than listing the entire history, only a single directory is listed.  */

	first_dname = P_log_dname;
	log_starname = log_name_$starname (P_log_name);

	P_oldest_log_name = "";
	P_newest_log_name = "";
	P_log_count = 0;

	total_segment_count = 0;			/* We started with none, after all */
	log_read_data_ptr = null ();
	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) begin;			/* Always free log_read_data, since it is not retained */
	     if (log_read_data_ptr ^= null ()) then	/* outside the invocation of this program */
		free log_read_data_ptr -> log_read_data in (system_area);
	end;

	call hcs_$get_uid_file (first_dname, "", first_uid, code); /* We need this value as a parameter, and, in */
	if (code ^= 0) then do;			/* any case, this is a good place to fail if noentry */
	     P_code = code;
	     return;
	end;

	call list_log_directory (first_dname, first_uid, "0"b); /* Just this directory, please */

	if (log_read_data.n_segments > 0) then do;
	     P_newest_log_name = log_read_data.ename (1);
	     P_oldest_log_name = log_read_data.ename (log_read_data.n_segments);
	end;

	P_log_count = log_read_data.n_segments;

	if (log_read_data.n_segments = 0) then
	     P_code = error_table_$nomatch;
	else P_code = 0;

	free log_read_data_ptr -> log_read_data in (system_area);

	return;					/* All done for $single_dir */
%page;

get_dname_and_uid:
     procedure (P_log_segment_ptr, P_dname, P_uid) returns (bit (1) aligned);

declare  P_log_segment_ptr pointer parameter;
declare  P_dname char (*) parameter;
declare  P_uid bit (36) aligned parameter;

declare  code fixed bin (35);

/* This procedure extracts the directory name and directory UID for the pathname
   recorded in the previous log information in the supplied log. If any error
   occurs, it just gives up, terminating the search at that point. */


	if (P_log_segment_ptr = null ()) then return ("0"b);

	if (P_log_segment_ptr -> log_segment.previous_log_dir = "") then return ("0"b);

	call absolute_pathname_ (P_log_segment_ptr -> log_segment.previous_log_dir, P_dname, code);
	if (code ^= 0) then return ("0"b);

	call hcs_$get_uid_file (P_dname, "", P_uid, code);
	if (code ^= 0) then return ("0"b);

	return ("1"b);
     end get_dname_and_uid;



allocate_read_data:
     procedure ();

	log_read_data_n_segments = total_segment_count;
	last_segment_entered = total_segment_count + 1;	/* Because there are none at all in the array, yet */

	allocate log_read_data in (system_area) set (log_read_data_ptr);
	log_read_data.header.sentinel = LOG_READ_DATA_VERSION_SENTINEL;
	log_read_data.n_segments = total_segment_count;

	return;
     end allocate_read_data;
%page;

/* *	This textbook example of recursion is used to find all the log segments
   *	in whatever set of directories they may have been migrated to. It is
   *	called by the main "open" routine to list the directory that the newest
   *	log points back to, and it goes back from there. After it lists a
   *	directory, it examines the oldest log segment in that directory, and
   *	sees where it points for its "previous" log. If the directory thus
   *	indicated is different, it calls list_log_directory recursively, and
   *	does it all over again.
   *
   *	Once it runs out of directories, or if it encounters any error listing
   *	or examining directory contents, it allocated log_read_data and starts
   *	filling it in, from the bottom (oldest) up.
   *
   *	The process is controlled by two global variables: total_segment_count
   *	and last_segment_entered, which keep track of the total size of the
   *	structure, and of which entries have been filled in already. After the
   *	initial call to list_log_directory returns, the remaining (first) entry
   *	in log_read_data is filled in from the parameter we received. The log
   *	starname is also global, since all historical logs must have the same
   *	format for their names.
   *
   *	NOTE: Despite the names, it's list_this_directory, not list_log_directory,
   *	that actually calls hcs_$star_.  This procedure just collects the results.
*/

list_log_directory:
     procedure (P_dname, P_uid, P_keep_looking);

declare  P_dname char (*) parameter;			/* Directory to list */
declare  P_uid bit (36) aligned parameter;		/* Used to check equality of directories */
declare  P_keep_looking bit (1) aligned parameter;	/* Keep looking for the next older directory */

declare  sort_pointers_ptr pointer;
declare  1 sort_pointers aligned based (sort_pointers_ptr),
	 2 n_entries fixed bin,
	 2 ptr (star_entry_count refer (sort_pointers.n_entries)) pointer unaligned;

declare  code fixed bin (35);				/* Local copy */
declare  segment_count fixed bin;
declare  1 one_star_entry aligned like star_entries based;
declare  entry_idx fixed bin;
declare  last_log_name char (32);
declare  last_log_ptr pointer;
declare  older_dname char (168);
declare  older_uid bit (36) aligned;
declare  segment_idx fixed bin;
%page;

	star_entry_ptr = null ();			/* Initialize for cleanup handler */
	star_names_ptr = null ();			/* Initialize for cleanup handler */
	sort_pointers_ptr = null ();			/* Initialize for cleanup handler */
	last_log_ptr = null ();			/* Initialize for filling into log_read_data */
	segment_count = 0;				/* Initialize for filling-in loop */

	on condition (cleanup) begin;
	     call free_star_entries ();
	end;

/* Now, we list the contents of the directory. It's the job of list_this_directory
   to test P_keep_looking-- if we aren't supposed to keep looking, it gives up
   without looking in the oldest log segment for another directory to list.
   Otherwise, it looks there and returns "1"b if there's anything worth looking at. */

	if (list_this_directory ()) then
	     call list_log_directory (older_dname, older_uid, P_keep_looking);
	else call allocate_read_data ();

/* Once the directory is listed, fill in all the segments from our list. This loop will
   be ignored if there was nothing listed by the earlier call to list_directory, so there
   are no problems resulting from referencing structures not actually allocated because,
   for instance, a call to hcs_$star_ failed. */

	do segment_idx = segment_count to 1 by -1;
	     last_segment_entered = last_segment_entered - 1; /* Get the index of the one to be entered */

	     log_read_data.dname (last_segment_entered) = P_dname;
	     log_read_data.dir_uid (last_segment_entered) = P_uid;
	     log_read_data.ename (last_segment_entered) =
		star_names (sort_pointers.ptr (segment_idx) -> one_star_entry.nindex);

	     log_read_data.suffix_time (last_segment_entered) =
		log_name_$time (log_read_data.ename (last_segment_entered));

	     if (segment_idx = segment_count) then	/* We've initiated (or at least tried) the oldest log */
		log_read_data.ptr (last_segment_entered) = last_log_ptr; /* already, so record the pointer we got */
	     else log_read_data.ptr (last_segment_entered) = null ();
	end;

	call free_star_entries ();			/* Clean out this level of recursion */
	return;
%page;

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

/* First, try to list any matching logs in the directory. If there is an error, or none
   can be found, we're all done here. A "0"b is returned if there are no more directories
   to search, which is the case for all returns except the very last. */

	     call hcs_$star_ (P_dname, log_starname, star_BRANCHES_ONLY, system_area_ptr,
		star_entry_count, star_entry_ptr, star_names_ptr, code);
	     if (code ^= 0) then return ("0"b);
	     if (star_entry_count = 0) then return ("0"b);

	     allocate sort_pointers in (system_area) set (sort_pointers_ptr);
	     sort_pointers.n_entries = star_entry_count;

	     segment_count = 0;
	     do entry_idx = 1 to star_entry_count;
		sort_pointers.ptr (entry_idx) = addr (star_entries (entry_idx));
		if (star_entries.type (entry_idx) = star_SEGMENT) then
		     segment_count = segment_count + 1;
	     end;

	     if (segment_count = 0) then return ("0"b);
	     total_segment_count = total_segment_count + segment_count;

	     call sort_items_$general (addr (sort_pointers), compare_entries);

	     if ^P_keep_looking then			/* If we're not supposed to keep looking, we */
		return ("0"b);			/* stop right here without looking at the history */

/* Find the last (oldest) log in this directory, and see what it says about earlier ones */

	     last_log_name = star_names (sort_pointers.ptr (segment_count) -> one_star_entry.nindex);
	     call log_initiate_ (P_dname, last_log_name, 1, last_log_ptr, code);
	     if (code ^= 0) then return ("0"b);

/* See if this log contains a usable previous log pathname */

	     if ^get_dname_and_uid (last_log_ptr, older_dname, older_uid) then return ("0"b);

/* Now, check to see whether the "previous" directory in the oldest log of record is
   different from the directory we're already looking at. This will fail catastrophically
   if the "previous" directory is, in fact, one we've listed earlier than this call,
   since it will lead us back to here, and so forth. It's difficult to check for that
   case, so we'll just take the risk. */

	     if (older_uid = P_uid) then return ("0"b);

	     return ("1"b);
	end list_this_directory;
%page;

compare_entries:
	procedure (P_entry_1, P_entry_2) returns (fixed bin (35));

declare  P_entry_1 unaligned pointer parameter;
declare  P_entry_2 unaligned pointer parameter;

declare  entry_1_ptr pointer;
declare  entry_2_ptr pointer;
declare  1 entry_1 aligned like star_entries based (entry_1_ptr);
declare  1 entry_2 aligned like star_entries based (entry_2_ptr);


	     entry_1_ptr = P_entry_1;
	     entry_2_ptr = P_entry_2;

/* These first two cases make non-segments always sort at the end, which means
   they will be ignored when collection time comes. */

	     if (entry_1.type = star_SEGMENT) & (entry_2.type ^= star_SEGMENT) then
		return (-1);
	     else if (entry_1.type ^= star_SEGMENT) & (entry_2.type = star_SEGMENT) then
		return (1);
	     else if (star_names (entry_1.nindex) < star_names (entry_2.nindex)) then
		return (1);
	     else return (-1);

	end compare_entries;



free_star_entries:
	procedure ();

declare  star_stuff fixed bin based;

/* This procedure has to have its own based variable to use when freeing, because the
   standard include file declares the star structures in a way that requires various
   pointers to be set properly when they may not be. BRAINDAMAGE. It should use fixed
   array bounds the way it used to before Davidoff got to it. */


	     if (star_entry_ptr ^= null ()) then
		free star_entry_ptr -> star_stuff in (system_area);
	     if (star_names_ptr ^= null ()) then
		free star_names_ptr -> star_stuff in (system_area);
	     if (sort_pointers_ptr ^= null ()) then
		free sort_pointers in (system_area);

	     return;
	end free_star_entries;

%page;

/* This must be declared here, in the internal procedure, because it is used recursively */

%include star_structures;

     end list_log_directory;				/* The recursive procedure */

/* format: off */
%page; %include log_segment;
%page; %include log_read_data;

	end log_list_history_;




		    log_move_.pl1                   11/11/89  1059.9rew 11/11/89  0802.0       27387



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

/* *	LOG_MOVE_
   *
   *	This procedure moves a message from one log segment to another
   *	(using log_write_ to create the new message), and deletes the 
   *	old message from the original log segment, ensuring that a 
   *	loop of moves can be restarted after an interruption without
   *	copying more than one extra message.
   *
   *	It would be swift to add a new entrypoint for ring zero that 
   *	used log_segment_ instead of log_write_, but that's not needed
   *	until the syserr_data segment is converted to be a log segment.
   *
   *	Modification history:
   *	1984-11-11, W. Olin Sibert: Initial coding
   *	1984-12-21, WOS: Changed to make data_class the right size (16 chars)
   */

declare   P_log_write_data_ptr pointer parameter;
declare   P_old_ptr pointer parameter;
declare   P_new_ptr pointer parameter;
declare   P_code fixed bin (35) parameter;

declare   code fixed bin (35);
declare   log_write_data_ptr pointer;
declare   old_ptr pointer;
declare   new_ptr pointer;
declare   data_class char (16) varying;

declare   log_data_$deleted_message_flag bit (36) aligned external static;

declare	log_segment_$finish_message entry (pointer, pointer, fixed bin (35));
declare	log_write_$general entry
         (pointer, fixed bin (35), fixed bin, fixed bin, char (16) varying, pointer, fixed bin (35));

/*  */

log_move_$message:
     entry (P_log_write_data_ptr, P_old_ptr, P_new_ptr, P_code);

	log_write_data_ptr = P_log_write_data_ptr;
	old_ptr = P_old_ptr;

	if (dimension (old_ptr -> log_message.data, 1) > 0) then
	     data_class = old_ptr -> log_message.data_class;
	else data_class = "";

	call log_write_$general (log_write_data_ptr,
	     old_ptr -> log_message.sequence,
	     length (old_ptr -> log_message.text), 
	     dimension (old_ptr -> log_message.data, 1),
	     data_class, new_ptr, code);

	if (code ^= 0) then 
	     goto FINISHED;

	new_ptr -> log_message.time = old_ptr -> log_message.time;
	new_ptr -> log_message.severity = old_ptr -> log_message.severity;
	new_ptr -> log_message.process_id = old_ptr -> log_message.process_id;
	new_ptr -> log_message.text = old_ptr -> log_message.text;

	if (dimension (old_ptr -> log_message.data, 1) > 0) then
	     unspec (new_ptr -> log_message.data) = unspec (old_ptr -> log_message.data);
	
	call log_segment_$finish_message (pointer (new_ptr, 0), new_ptr, code);

	old_ptr -> log_message.sentinel = log_data_$deleted_message_flag;

	P_new_ptr = new_ptr;

FINISHED:
	P_code = code;
	return;

%page; %include log_message;

	end log_move_;




		    log_read_.pl1                   11/11/89  1059.9rew 11/11/89  0800.0      418338



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


/****^  HISTORY COMMENTS:
  1) change(85-06-11,Margulies), approve(86-02-21,MCR7344),
     audit(86-02-21,EJSharpe), install(86-04-23,MR12.0-1044):
     Update very_last_time on any time search, and very_last_sequence on any
     sequence search.
                                                   END HISTORY COMMENTS */


/* format: style4 */
log_read_:
     procedure ();

/* *	LOG_READ_
   *
   *	This is the user-ring log reading procedure. More comments to come
   *	later.
   *
   *	84-06-05, W. Olin Sibert
   *	84-10-09, E. Swenson to handle setting limits on an empty log.
   *      84-11-26, BIM: added $update for use in monitoring.
   *	84-11-28, Steve Herbst: Added $open_with_procedure, which sets
   *		entry variables in log_read_data.
   *	84-12-06, Steve Herbst: Added $hold_message, $free_message,
   *		$get_log_uid, $register, and $deregister.
   *    1984-12-15, BIM: various debugging changes to the above.
   *    1985-01-25, BIM: no zero code on null log message ptr.
   *    1985-02-18, EJ Sharpe: optimizations (binary search for message time
   *		or sequence numbers.  Use suffix_time when searching for
   *		specific message time to avoid some initiates.
   *    1985-03-15, Lindsey Spratt, Steve Herbst: Fixed to allocate held
   *		message nodes in system_area instead of caller_area.
   *    1985-03-18, Steve Herbst: Fixed $open entries to abort if current
   *		log segment is null and previous not found.
*/

declare  P_log_dname char (*) parameter;
declare  P_log_ename char (*) parameter;
declare  P_log_read_data_ptr pointer parameter;
declare  P_log_message_ptr pointer parameter;
declare  P_open_info_ptr pointer parameter;
declare  P_message_sequence fixed bin (35) parameter;
declare  P_message_time fixed bin (71) parameter;
declare  P_event_channel fixed bin (71) parameter;
declare  P_log_uid bit (36) aligned parameter;
declare  P_process_id bit (36) aligned parameter;
declare  P_search_direction bit (1) aligned parameter;
declare  P_code fixed bin (35) parameter;

declare  allocate_copies bit (1) aligned;
declare  code fixed bin (35);
declare  procedure_name char (32);
declare  caller_area_ptr pointer;
declare  good_log_read_data_ptr pointer;
declare  system_area_ptr pointer;
declare  log_in_service bit (1) aligned;
declare  log_idx fixed bin;
declare  message_sequence fixed bin (35);
declare  new_log_read_data_ptr pointer;

declare  system_area area based (system_area_ptr);

declare  error_table_$badcall fixed bin (35) external static;
declare  error_table_$fatal_error fixed bin (35) external static;
declare  error_table_$log_segment_damaged fixed bin (35) external static;
declare  error_table_$no_log_message fixed bin (35) external static;
declare  error_table_$null_info_ptr fixed bin (35) ext static;
declare  error_table_$unimplemented_version fixed bin (35) ext static;

declare  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
						/* DBG declare  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); /* DBG */
declare  get_system_free_area_ entry () returns (pointer);
declare  hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35));
declare  hcs_$terminate_noname entry (pointer, fixed bin (35));
						/* DBG declare  ioa_ entry options (variable);			/* DBG */
declare  log_initiate_ entry (char (*), char (*), fixed bin, pointer, fixed bin (35));
declare  log_list_history_$all entry (pointer, char (*), fixed bin, pointer);
declare  log_position_$find_sequence entry (pointer, fixed bin (35), bit (1) aligned, pointer, bit (1) aligned);
declare  log_position_$find_time entry (pointer, fixed bin (71), bit (1) aligned, pointer, bit (1) aligned);
declare  log_position_$next_message entry (pointer, pointer, bit (1) aligned);
declare  log_position_$prev_message entry (pointer, pointer, bit (1) aligned);
declare  log_segment_$get_service_bit entry (pointer, bit (1) aligned, fixed binary (35));
declare  log_wakeup_$register entry (pointer, bit (36) aligned, fixed bin (71), fixed bin (35));
declare  log_wakeup_$deregister entry (pointer, bit (36) aligned, fixed bin (71), fixed bin (35));
declare  sub_err_ entry options (variable);

declare  cleanup condition;

declare  (clock, codeptr, divide, hbound, max, min, null, segno, setwordno, unspec) builtin;
%page;

log_read_$open:
     entry (P_log_dname, P_log_ename, P_log_read_data_ptr, P_code);

	P_log_read_data_ptr = null ();
	P_code = 0;

	procedure_name = "";
	caller_area_ptr = get_system_free_area_ ();
	allocate_copies = "0"b;

	go to OPEN_COMMON;

log_read_$open_long:
     entry (P_log_dname, P_log_ename, P_open_info_ptr, P_log_read_data_ptr, P_code);


	P_log_read_data_ptr = null ();
	P_code = 0;

	log_read_open_info_ptr = P_open_info_ptr;
	if log_read_open_info.version ^= LOG_READ_OPEN_INFO_VERSION_1
	then call finished (error_table_$unimplemented_version);

	procedure_name = log_read_open_info.reader_procedure;
	caller_area_ptr = log_read_open_info.allocation_area_ptr;
	allocate_copies = log_read_open_info.allocate_copies;
	if procedure_name ^= "" & allocate_copies
	then call finished (error_table_$badcall);	/* too hard to implement, it gets VERY confusing in $update */

OPEN_COMMON:
	log_read_data_ptr, good_log_read_data_ptr = null ();
	system_area_ptr = get_system_free_area_ ();

	on condition (cleanup) begin;
	     call log_read_$close (good_log_read_data_ptr, (0));
	end;

	log_read_data_n_segments = 1;
	allocate log_read_data in (system_area) set (log_read_data_ptr);
	unspec (log_read_data) = ""b;
	log_read_data.sentinel = LOG_READ_DATA_VERSION_SENTINEL;
	log_read_data.n_segments = log_read_data_n_segments;
	log_read_data.reader_data_ptr = null ();
	log_read_data.first_held_message_ptr = null ();
	log_read_data.latest_message = null ();
	log_read_data.earlier_message = null ();
	log_read_data.last_held_message_ptr = null ();
	log_read_data.ptr (*) = null ();
	log_read_data.history_complete = "0"b;
	log_read_data.call_procedures = (procedure_name ^= "");
	log_read_data.user_area_ptr = caller_area_ptr;
	log_read_data.allocate_copies = allocate_copies;

	begin;
declare  1 null_entry aligned,
	 2 code ptr,
	 2 env ptr;
declare  nulle entry variable;

	     null_entry.code = null ();
	     null_entry.env = null ();
	     unspec (nulle) = unspec (null_entry);
	     log_read_data.ev = nulle;		/* aggregate */
	end;

	if log_read_data.call_procedures then do;

	     call set_entry_variable (log_read_data.ev.open, procedure_name, "open");
	     call set_entry_variable (log_read_data.ev.close, procedure_name, "close");
	     call set_entry_variable (log_read_data.ev.prev_message, procedure_name, "prev_message");
	     call set_entry_variable (log_read_data.ev.next_message, procedure_name, "next_message");
	     call set_entry_variable (log_read_data.ev.position_time, procedure_name, "position_time");
	     call set_entry_variable (log_read_data.ev.position_sequence, procedure_name, "position_sequence");
	     call set_entry_variable (log_read_data.ev.update, procedure_name, "update");
	     call set_entry_variable (log_read_data.ev.hold_message, procedure_name, "hold_message");
	     call set_entry_variable (log_read_data.ev.free_message, procedure_name, "free_message");
	     call set_entry_variable (log_read_data.ev.get_log_uid, procedure_name, "get_log_uid");
	end;

	good_log_read_data_ptr = log_read_data_ptr;	/* can be used now by log_read_$close above */


	if log_read_data.call_procedures then do;
	     call log_read_data.ev.open (P_log_dname, P_log_ename,
		caller_area_ptr, log_read_data.reader_data_ptr, code);
	     if code ^= 0 then call finished (code);
	     go to OPEN_GOOD_RETURN;			/* The remainder is in the inner ring */
	end;

/* Try to initiate the beginning segment in the log family.  Any
   error at this stage, and we just give up. */

	log_idx = 1;
	log_read_data.dname (1) = P_log_dname;
	log_read_data.ename (1) = P_log_ename;

	call initiate_log (1);
	if (code ^= 0) then do;
	     call log_read_$close (log_read_data_ptr, (0));
	     call finished (code);
	end;

	log_read_data.suffix_time (1) = clock ();	/* A reasonable default-- logged messages will be earlier */

	call get_complete_history ();

	call look_for_log_segment (log_read_data.n_segments, 1); /* Set up the limits in the header */
	if log_segment_ptr = null () then call finished (error_table_$fatal_error);

	log_read_data.very_first_log_idx = log_idx;	/* Start with oldest (first) message */
	log_read_data.very_first_sequence = log_segment.first_sequence;
	log_read_data.very_first_time = log_segment.first_time;

	call look_for_log_segment (1, log_read_data.n_segments); /* Find newest (last) message */
	if log_segment_ptr = null () then call finished (error_table_$fatal_error);

	if log_segment.first_sequence = 0 & log_segment.last_sequence = 0 then do; /* Log is empty */
	     call look_for_log_segment (2, log_read_data.n_segments); /* Find previous log */
	     if log_segment_ptr = null then call finished (error_table_$fatal_error);
	end;

	log_read_data.very_last_log_idx = log_idx;
	log_read_data.very_last_sequence = log_segment.last_sequence;
	log_read_data.very_last_time = log_segment.last_time;
OPEN_GOOD_RETURN:
	P_log_read_data_ptr = log_read_data_ptr;

	call finished (0);
%page;

log_read_$close:
     entry (P_log_read_data_ptr, P_code);

	P_code = 0;
	if P_log_read_data_ptr = null () then return;
	call check_in_pointer;

	if log_read_data.call_procedures then do;
	     P_log_read_data_ptr = null ();
	     call log_read_data.ev.close (log_read_data.reader_data_ptr, code);
	     call finished (code);
	end;

	if log_read_data.allocate_copies then
	     call free_held_messages ();

	P_log_read_data_ptr = null ();
	system_area_ptr = get_system_free_area_ ();

	do log_idx = 1 to hbound (log_read_data.ptr, 1);
	     if (log_read_data.ptr (log_idx) ^= null ()) then
		call hcs_$terminate_noname (log_read_data.ptr (log_idx), (0));
	end;

	free log_read_data in (system_area);
	call finished (0);
%page;

log_read_$next_message:
     entry (P_log_read_data_ptr, P_log_message_ptr, P_code);

	call check_in_pointer;
	log_message_ptr = P_log_message_ptr;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.next_message (log_read_data.reader_data_ptr, P_log_message_ptr, code);
	     call finished (code);
	end;

	if log_read_data.allocate_copies then
	     log_message_ptr = lookup_message (log_message_ptr); /* turn ptr to user's copy into real msg ptr */
	if (log_message_ptr = null ()) then do;
	     call look_for_log_segment (log_read_data.n_segments, 1); /* Look through them all, backwards */
	     if (log_segment_ptr = null ()) then call finished (code); /* Couldn't find anything, punt */
	end;

	else call find_log_idx_of_message ();

	call log_position_$next_message (log_segment_ptr, log_message_ptr, log_read_data.damaged (log_idx));

	if (log_message_ptr = null ()) then do;		/* Not in that segment, try the next one */
	     call look_for_log_segment ((log_idx - 1), 1);/* Search remaining ones */
	     if (log_segment_ptr = null ()) then call finished (error_table_$no_log_message);

	     call log_position_$next_message (log_segment_ptr, log_message_ptr, log_read_data.damaged (log_idx));
	     if log_message_ptr = null ()		/* still no one home */
	     then call finished (error_table_$no_log_message); /* So say so */
	end;

/**** Arrive here with a found message in our mouth */

	if log_read_data.allocate_copies
	then call short_hold_message (log_message_ptr);	/* input-output, replaces pointer with copy */

	P_log_message_ptr = log_message_ptr;
	call finished (0);
%page;

log_read_$prev_message:
     entry (P_log_read_data_ptr, P_log_message_ptr, P_code);
	call check_in_pointer;
	log_message_ptr = P_log_message_ptr;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.prev_message (log_read_data.reader_data_ptr, P_log_message_ptr, code);
	     call finished (code);
	end;

	if log_read_data.allocate_copies then
	     log_message_ptr = lookup_message (log_message_ptr); /* turn ptr to user's copy into real msg ptr */
	if (log_message_ptr = null ()) then do;
	     call look_for_log_segment (1, log_read_data.n_segments); /* Look through them all, from the end */
	     if (log_segment_ptr = null ()) then	/* Couldn't find anything, punt */
		call finished (code);
	end;

	else call find_log_idx_of_message ();

	call log_position_$prev_message (log_segment_ptr, log_message_ptr, log_read_data.damaged (log_idx));

	if (log_message_ptr = null ()) then do;		/* Not in that segment, try the previous one */
	     call look_for_log_segment ((log_idx + 1), log_read_data.n_segments); /* Search remaining ones */
	     if (log_segment_ptr = null ()) then
		call finished (error_table_$no_log_message);

	     call log_position_$prev_message (log_segment_ptr, log_message_ptr, log_read_data.damaged (log_idx));
	     if log_message_ptr = null ()		/* Still no one home? Must be an emptr segment. */
	     then call finished (error_table_$no_log_message);
	end;

	if log_read_data.allocate_copies
	then call short_hold_message (log_message_ptr);	/* input-output, replaces pointer with copy */

	P_log_message_ptr = log_message_ptr;
	call finished (0);
%page;

log_read_$position_sequence:
     entry (P_log_read_data_ptr, P_message_sequence, P_search_direction, P_log_message_ptr, P_code);

	call check_in_pointer;
	P_log_message_ptr = null ();

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.position_sequence (log_read_data.reader_data_ptr, P_message_sequence,
		P_search_direction, P_log_message_ptr, code);
	     call finished (code);
	end;

	call sequence_search (P_search_direction);

	if log_read_data.allocate_copies
	then call short_hold_message (log_message_ptr);	/* input-output, replaces pointer with copy */

	P_log_message_ptr = log_message_ptr;
	if (log_message_ptr = null ()) then
	     call finished (error_table_$no_log_message);
	else call finished (0);
%page;

log_read_$position_time:
     entry (P_log_read_data_ptr, P_message_time, P_search_direction, P_log_message_ptr, P_code);

	call check_in_pointer;
	P_log_message_ptr = null ();

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.position_time (log_read_data.reader_data_ptr, P_message_time,
		P_search_direction, P_log_message_ptr, code);
	     call finished (code);
	end;
	call time_search (P_search_direction);

	if log_read_data.allocate_copies
	then call short_hold_message (log_message_ptr);	/* input-output, replaces pointer with copy */

	P_log_message_ptr = log_message_ptr;
	if (log_message_ptr = null ()) then
	     call finished (error_table_$no_log_message);
	else call finished (0);
%page;

/**** This entrypoint may close and reopen the log, resetting
      the log_read_data_ptr.

      This entrypoint checks the in_service state of the log,
      and closes and reopens if it is not in service. */


log_read_$update:
     entry (P_message_sequence, P_log_read_data_ptr, P_log_message_ptr, P_code);

	call check_in_pointer;

	call update_procedure ();
	return;
%page;

log_read_$hold_message:
     entry (P_log_read_data_ptr, P_log_message_ptr);

	call check_in_pointer;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.hold_message (log_read_data.reader_data_ptr, P_log_message_ptr);
	     return;				/* DO NOT pass through finish, we have no output code */
	end;

	if log_read_data.allocate_copies
	then do;
	     log_message_ptr = lookup_message (P_log_message_ptr); /* demand that we have it someplace */
	     call hold_message (log_message_ptr, P_log_message_ptr); /* actual, copy */
	     if log_message_ptr = log_read_data.latest_message.actual_ptr
	     then log_read_data.latest_message = null (); /* To avoid having to make sure that the ref count is set to 2 */
	     if log_message_ptr = log_read_data.earlier_message.actual_ptr
	     then log_read_data.earlier_message = null ();/* To avoid having to make sure that the ref count is set to 2 */
	end;
	return;
%page;

log_read_$free_message:
     entry (P_log_read_data_ptr, P_log_message_ptr);

	call check_in_pointer;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.free_message (log_read_data.reader_data_ptr, P_log_message_ptr);
	     return;
	end;

	if log_read_data.allocate_copies then do;
	     call free_message (P_log_message_ptr);	/* search for the COPY */
	end;
	return;
%page;

log_read_$get_log_uid:
     entry (P_log_read_data_ptr, P_log_uid, P_code);

	call check_in_pointer;
	P_code = 0;
	P_log_uid = "0"b;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.get_log_uid (log_read_data.reader_data_ptr, P_log_uid, code);
	     call finished (code);
	end;

	call hcs_$get_uid_seg (log_read_data.segments (1).ptr,
	     P_log_uid, code);
	call finished (code);
%page;

log_read_$register:
     entry (P_log_read_data_ptr, P_process_id, P_event_channel, P_code);

	call check_in_pointer;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.register (log_read_data.reader_data_ptr, P_process_id, P_event_channel, code);
	     call finished (code);
	end;

	call log_wakeup_$register (log_read_data.segments (1).ptr, P_process_id, P_event_channel, code);
	call finished (code);
%page;

log_read_$deregister:
     entry (P_log_read_data_ptr, P_process_id, P_event_channel, P_code);

	call check_in_pointer;

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.deregister (log_read_data.reader_data_ptr, P_process_id, P_event_channel, code);
	     call finished (code);
	end;

	call log_wakeup_$deregister (log_read_data.segments (1).ptr, P_process_id, P_event_channel, code);
	call finished (code);
%page;

sequence_search:
     procedure (P_after_sw);

declare  P_after_sw bit (1) aligned parameter;

declare  message_sequence fixed bin (35);
declare  found bit (1);


	message_sequence = P_message_sequence;

	call set_current_log (log_read_data.very_last_log_idx); /* update the last sequence number, messages may have arrived */
	log_read_data.very_last_sequence = log_segment.last_sequence;

	if P_after_sw then do;
	     if (message_sequence <= log_read_data.very_first_sequence) then do;
		call set_current_log (log_read_data.very_first_log_idx);
		log_message_ptr = null ();		/* Force position to first message */
		call log_position_$next_message (log_segment_ptr, log_message_ptr, ("0"b));
	     end;

	     else if (message_sequence > log_read_data.very_last_sequence) then
		log_message_ptr = null ();

	     else call search_for_sequence ();
	end;

	else if ^P_after_sw then do;
	     if (message_sequence >= log_read_data.very_last_sequence) then do;
		call set_current_log (log_read_data.very_last_log_idx);
		log_message_ptr = null ();		/* Force position to last message */
		call log_position_$prev_message (log_segment_ptr, log_message_ptr, ("0"b));
	     end;

	     else if (message_sequence < log_read_data.very_first_sequence) then
		log_message_ptr = null ();

	     else call search_for_sequence ();
	end;

	return;
%page;
/* This routine implements a binary search to find the particular message
   sequence number we want.  It may turn out that that sequence does not exist
   (due to message or log segments lost).  In that case we'll find an acceptable
   substitute consistant sith P_after_sw. */

search_for_sequence: procedure ();

declare  found bit (1);
declare  test_idx fixed bin;
declare  low_idx fixed bin;
declare  high_idx fixed bin;


	     log_message_ptr = null ();

/* We'll try the newest log segment.  If the sequence we're
   interested in is there, we can avoid the binary search.  The
   newest log is already initiated, so this isn't too expensive. */

	     call look_for_log_segment (log_read_data.very_last_log_idx, log_read_data.very_first_log_idx);
	     if log_idx = 0				/* all the log segments damaged? */
	     then return;
	     else if message_sequence >= log_segment.first_sequence & message_sequence <= log_segment.last_sequence
	     then goto call_log_position;		/* found it, now position to message */

/* set up for binary search */

	     found = "0"b;

	     low_idx = log_idx + 1;			/* skip one(s) we've already looked at */
	     high_idx = log_read_data.very_first_log_idx; /* last log in list (oldest) */

/* DBG call ioa_ ("Test sequence is ^d", message_sequence); /* DBG */
	     do while ((low_idx <= high_idx) & ^found);

		test_idx = divide ((high_idx - low_idx), 2, 17, 0) + low_idx;

/* Initiate the log segment whose index is test_idx.  We'll compare the
   first and last sequence number values against the sequence we're looking
   for.
   The internal proc "look_for_log_segment" is called to perform the
   initiation.  If the desired segment can't be initiated (i.e. it's damaged)
   look_for_log_segment will try the next in sequence automatically.  We
   tell it in which direction to search based upon P_after_sw.
   It may very well happen that look_for_log_segment will hit
   the end of the partition we're working with.  It that case, we'll adjust
   the partition and try again. */

		call look_for_log_segment (test_idx, high_idx);
		if log_idx = 0			/* unable to get any log segment? */
		then high_idx = test_idx;		/* get damaged segs out of partition */

/* See if what we're looking for is in this log segment.  If not, we must
   adjust the search partition to contain the range of log segments that are
   still candidates.  This will be the upper or lower half of the current
   partition.  Note the optimization in which we ignore those indicies between
   test_idx and log_idx, these are damaged log segments and should not be
   included in this partitioning. */

		else do;
						/* DBG call ioa_ ("Partition= ^d to ^d; test= ^d^[ *Actually ^d*^;^s^] (^d to ^d)",
						   low_idx, high_idx, test_idx, (test_idx^=log_idx), log_idx,
						   log_segment.first_sequence, log_segment.last_sequence);/*DBG */

		     if message_sequence >= log_segment.first_sequence & message_sequence <= log_segment.last_sequence
		     then found = "1"b;
		     else if message_sequence < log_segment.last_sequence
		     then low_idx = log_idx + 1;	/* partition to older half */
		     else high_idx = test_idx - 1;	/* partition to younger half */
		end;
	     end;


/* If we were unable to find a log segment that contains the desired sequence
   number, we must assume that number falls between a pair of existing log segments.
   One of the pair is at the index we currently hold.  Here we'll check to see
   if we really shouldn't be looking at the other of the pair.  The value of
   P_after_sw will help us decide. */

	     if ^found
	     then if P_after_sw
		then if message_sequence > log_segment.last_sequence
		     then do;
			test_idx = max (test_idx - 1, log_read_data.very_last_log_idx);
						/* pick up next younger log segment, if there is one */
			call look_for_log_segment (test_idx, log_read_data.very_last_log_idx);
		     end;
		     else ;			/* we've got the better choice already */

		else if message_sequence < log_segment.first_sequence
		then do;
		     test_idx = min (test_idx + 1, log_read_data.very_first_log_idx);
						/* pick up next older log segment, if there is one */
		     call look_for_log_segment (test_idx, log_read_data.very_first_log_idx);
		end;
		else ;				/* we've got the better choice already */
	     else ;

	     if log_segment_ptr = null ()
	     then return;				/* couldn't find anything good */

/* And finally we can have log_position_ get us to the specific message
   within the log segment. */

	     if message_sequence >= log_segment.first_sequence & message_sequence <= log_segment.last_sequence
	     then do;
call_log_position:
		call log_position_$find_sequence (log_segment_ptr, message_sequence, P_after_sw, log_message_ptr, ("0"b));
	     end;
	     else do;
						/* We won't have an exact match, get the first message in the
						   next log or the last message in the previous log. */
		if P_after_sw
		then call log_position_$next_message (log_segment_ptr, log_message_ptr, ("0"b));
		else call log_position_$prev_message (log_segment_ptr, log_message_ptr, ("0"b));
	     end;

	end search_for_sequence;


     end sequence_search;
%page;

set_entry_variable:
     procedure (P_entry_variable, P_procedure_name, P_entry_name);

declare  P_entry_variable variable entry parameter;
declare  P_entry_name char (*) parameter;
declare  P_procedure_name char (*) parameter;

RETRY:
	P_entry_variable = cv_entry_ (P_procedure_name || "$" || P_entry_name, codeptr (log_read_), code);
	if (code = 0) then return;

	call sub_err_ (code, "log_read_", ACTION_CAN_RESTART, null (), (0), "Failed to snap link to ^a$^a.", P_procedure_name, P_entry_name);
	go to RETRY;

     end set_entry_variable;
%page;

time_search:
     procedure (P_after_sw);

declare  P_after_sw bit (1) aligned parameter;

declare  message_time fixed bin (71);


	message_time = P_message_time;


	call set_current_log (log_read_data.very_last_log_idx); /* update our notion of the last time in the family */
	log_read_data.very_last_time = log_segment.last_time; /* since messages may have arrived */

	if P_after_sw then do;
	     if (message_time <= log_read_data.very_first_time) then do;
		call set_current_log (log_read_data.very_first_log_idx);
		log_message_ptr = null ();		/* Force position to first message */
		call log_position_$next_message (log_segment_ptr, log_message_ptr, ("0"b));
	     end;

	     else if (message_time > log_read_data.very_last_time) then
		log_message_ptr = null ();

	     else call search_for_time ();
	end;

	else if ^P_after_sw then do;
	     if (message_time >= log_read_data.very_last_time) then do;
		call set_current_log (log_read_data.very_last_log_idx);
		log_message_ptr = null ();		/* Force position to last message */
		call log_position_$prev_message (log_segment_ptr, log_message_ptr, ("0"b));
	     end;

	     else if (message_time < log_read_data.very_first_time) then
		log_message_ptr = null ();

	     else call search_for_time ();
	end;

	return;
%page;

/* This routine implements a binary search to find
   a message near the desired time.  Here we attempt to initiate as few log
   segments as possible.  Rather than peek at log_segment.last_time and
   log_segment.first_time we trust the segment time suffix. */

search_for_time: procedure;

declare  found bit (1);
declare  test_idx fixed bin;
declare  low_idx fixed bin;
declare  high_idx fixed bin;
declare  first_message_time fixed bin (71);


	     log_message_ptr = null ();

/* We'll first try the newest log segment.  If the time we're
   interested in is there, we can avoid the binary search.  The
   newest log is already initiated, so this isn't too expensive. */

	     call look_for_log_segment (log_read_data.very_last_log_idx, log_read_data.very_first_log_idx);
	     if log_idx = 0				/* all log segments damaged? */
	     then return;
	     else if message_time >= log_segment.first_time & message_time <= log_segment.last_time
	     then goto call_log_position;		/* found it, now position to message */

/* set up for binary search */

	     found = "0"b;

	     low_idx = log_idx + 1;			/* skip one(s) we've already looked at */
	     high_idx = log_read_data.very_first_log_idx; /* last log in list (oldest) */

/* DBG call ioa_ ("Test time is ^a.",
   date_time_$format ("date_time", message_time, "", ""));/* DBG */

	     do while ((low_idx <= high_idx) & ^found);

		test_idx = divide ((high_idx - low_idx), 2, 17, 0) + low_idx;

/* Get the time of the first message in this log segment.  We do this
   by looking at the time of the last message in the previous log segment.
   A side effect is that we'll always find a log segment in our search (since
   all times between very_first_time and very_last_time will be included).
   This happens regardless of missing log segments.  There is a chance that
   we'll get the wrong one this way, an extra check is made later - once the
   segment we select is initiated. */

		if test_idx < log_read_data.very_first_log_idx
		then first_message_time = log_read_data.segments (test_idx + 1).suffix_time + 1; /* this may be way off */
		else first_message_time = log_read_data.very_first_time;

/* DBG call ioa_ ("Partition= ^d to ^d; test= ^d (^a to ^a)",
   low_idx, high_idx, test_idx,
   date_time_$format ("date_time", first_message_time, "", ""),
   date_time_$format ("date_time",
   log_read_data.segments(test_idx).suffix_time, "", ""));/* DBG */

/* See if what we're looking for is in this log segment.  If not, adjust
   the search partition to include only those segments which are still
   possible candidates. */

		if message_time >= first_message_time & message_time <= log_read_data.segments (test_idx).suffix_time
		then found = "1"b;
		else if message_time < log_read_data.segments (test_idx).suffix_time
		then low_idx = test_idx + 1;		/* partition to older half */
		else high_idx = test_idx - 1;		/* partition to younger half */
	     end;


	     if ^found then return;			/* must always find a log segment */


/* Now get the log segment we've selected initiated.  Note that
   "look_for_log_segment" may give us something different.  This happens if the
   log we selected is damaged.  The direction of search for an undamaged log
   segment is determined by the value of P_after_sw. */

	     if P_after_sw
	     then call look_for_log_segment (test_idx, log_read_data.very_last_log_idx);
	     else call look_for_log_segment (test_idx, log_read_data.very_first_log_idx);


/* Now that we've actually got a log segment initiated we can check to see
   if our estimate re: log_segment.first_time (see first_message_time above) was
   OK.  We're only concerned if P_after_sw is false (implying backward searching). */

	     if ^P_after_sw
	     then if log_segment.first_time > message_time
		then if test_idx < log_read_data.very_first_log_idx
		     then do;
			test_idx = test_idx + 1;	/* go to previous log segment */
			call look_for_log_segment (test_idx, log_read_data.very_first_log_idx);
		     end;
		     else ;
		else ;
	     else ;

	     if log_segment_ptr = null ()
	     then return;				/* couldn't find anything good */

/* And finally we can have log_position_ get us to the specific message
   within the log segment. */

	     if message_time >= log_segment.first_time & message_time <= log_segment.last_time
	     then do;
call_log_position:
		call log_position_$find_time (log_segment_ptr, message_time, P_after_sw, log_message_ptr, ("0"b));
	     end;
	     else do;
						/* We won't have an exact match, get the first message in the
						   next log or the last message in the previous log. */
		if P_after_sw
		then call log_position_$next_message (log_segment_ptr, log_message_ptr, ("0"b));
		else call log_position_$prev_message (log_segment_ptr, log_message_ptr, ("0"b));
	     end;


	end search_for_time;

     end time_search;
%page;

find_log_idx_of_message:
     procedure ();

/* This procedure sets log_segment_ptr and log_idx to identify the log segment
   containing the log message we were passed as an argument.  If it's not
   the most recently used segment, a linear search is performed. */


	if (log_read_data.current_idx > 0) then
	     if (log_read_data.current_ptr = log_read_data.ptr (log_read_data.current_idx)) then
		if (segno (log_read_data.current_ptr) = segno (log_message_ptr)) then do;
		     log_idx = log_read_data.current_idx;
		     log_segment_ptr = log_read_data.current_ptr;
		     return;
		end;

	do log_idx = 1 to log_read_data.n_segments;
	     if (segno (log_read_data.ptr (log_idx)) = segno (log_message_ptr)) then do;
		call set_current_log (log_idx);	/* (re-)sets global log_idx, even though we have it here */
		return;
	     end;
	end;					/* of loop through segments */

/* If it's not one of the segments we know about, then it's flat wrong.
   Probably there is a better choice for status code, but this will do for now. */

	call finished (error_table_$fatal_error);

     end find_log_idx_of_message;
%page;

look_for_log_segment:
     procedure (P_start, P_finish);

/* This procedure sets log_segment_ptr and log_idx to identify the first segment
   it can initiate in the range specified. If none can be found, log_segment_ptr
   is set to null, log_idx to zero, and the caller gets to take appropriate action. */

declare  P_start fixed bin parameter;
declare  P_finish fixed bin parameter;

declare  increment fixed bin;
declare  test_idx fixed bin;


	if (P_start > P_finish) then			/* Force loop to proceed in right direction */
	     increment = -1;
	else increment = 1;

	code = 1;					/* Simulate DO ... UNTIL */
	do test_idx = P_start to P_finish by increment while (code ^= 0);
	     call initiate_log (test_idx);
	     if (code = 0) then log_idx = test_idx;	/* Remember the one that succeeded */
	end;

	if (code ^= 0) then				/* A zero invalidates the current log pointer */
	     call set_current_log (0);
	else call set_current_log (log_idx);		/* (re-)sets global log_idx, which is OK */

	return;
     end look_for_log_segment;
%page;

set_current_log:
     procedure (P_log_idx);

/* This procedure sets the values identifying the current log in log_read_data;
   these values are used solely as an optimization for find_log_idx_of_message.
   It also sets the global log_idx (often used as input) and log_segment_ptr values. */

declare  P_log_idx fixed bin parameter;


	if (P_log_idx = 0) then
	     log_segment_ptr = null ();
	else log_segment_ptr = log_read_data.ptr (P_log_idx);

	log_read_data.current_ptr = log_segment_ptr;
	log_read_data.current_idx = P_log_idx;

	log_idx = P_log_idx;

	return;
     end set_current_log;
%page;

initiate_log:
     procedure (P_idx);

declare  P_idx fixed bin parameter;


	if (log_read_data.damaged (P_idx)) then do;
	     code = error_table_$log_segment_damaged;
	     return;
	end;

	if (log_read_data.ptr (P_idx) ^= null ()) then do;
	     code = 0;				/* Indicate success */
	     return;
	end;

	call log_initiate_
	     (log_read_data.dname (P_idx), log_read_data.ename (P_idx), 10, log_read_data.ptr (P_idx), code);

	if (code ^= 0) then log_read_data.damaged (P_idx) = "1"b;

	return;
     end initiate_log;
%page;

get_complete_history:
     procedure ();

declare  new_log_read_data_ptr pointer;
declare  new_idx fixed bin;				/* NL */ declare saved_n_segments fixed bin;

/* This procedure is responsible for listing any remaining history
   for this log family-- it must be called every time we try to position
   before the beginning of the current history. It may change the value
   of log_read_data_ptr; however, because it only adds new entries at
   the end, it will NOT invalidate the current index into the log_read_data
   log array.  It is the calling routine's responsibility to pass the
   new version of log_read_data_ptr back to the caller, but since this
   routine is now called only at open time, this is not a problem. It
   will become a problem if the optimization to initiate only the first
   segment (until others are needed) is implemented. */


	if log_read_data.history_complete then return;	/* It's already happened */

	call log_list_history_$all
	     (log_read_data.ptr (1), log_read_data.ename (1), log_read_data.n_segments, new_log_read_data_ptr);

	if (new_log_read_data_ptr ^= null ()) then do;	/* There is some history, so replace our structure with it */
	     do new_idx = 1 to log_read_data.n_segments;
		new_log_read_data_ptr -> log_read_data.segments (new_idx) = log_read_data.segments (new_idx);
	     end;

/* Can't just copy the header, because that would copy log_read_data.n_segments,
   which still has the old value */

	     saved_n_segments = new_log_read_data_ptr -> log_read_data.n_segments;
	     new_log_read_data_ptr -> log_read_data.header = log_read_data.header;
	     new_log_read_data_ptr -> log_read_data.n_segments = saved_n_segments; /* NL */
	     system_area_ptr = get_system_free_area_ ();
	     free log_read_data_ptr -> log_read_data in (system_area);

	     log_read_data_ptr = new_log_read_data_ptr;
	     new_log_read_data_ptr = null ();
	end;

	log_read_data.history_complete = "1"b;		/* So we never have to go through this again */

	return;
     end get_complete_history;
%page;

MAIN_RETURN:
	return;
%page;

update_procedure:
     procedure ();

	log_message_ptr = P_log_message_ptr;
	if log_read_data.allocate_copies then log_message_ptr = lookup_message (log_message_ptr);

	if (log_message_ptr = null ()) then
	     call finished (error_table_$fatal_error);

	if log_read_data.call_procedures then do;
	     call log_read_data.ev.update (P_message_sequence, log_read_data.reader_data_ptr,
		P_log_message_ptr, code);
	     call finished (code);
	end;

	message_sequence = P_message_sequence;
	log_segment_ptr = setwordno (log_message_ptr, 0);
	call log_segment_$get_service_bit (log_segment_ptr, log_in_service, code);
	if code ^= 0 then call finished (code);
	if message_sequence >= log_segment.limits.first_sequence
	     & message_sequence <= log_segment.limits.last_sequence
	     & log_in_service then call finished (0);

	call log_read_$open (log_read_data.segments (1).dname, log_read_data.segments (1).ename,
	     new_log_read_data_ptr, code);
	if code ^= 0 then call finished (0);		/* leave well enough alone if this fails */

	call log_read_$position_sequence (new_log_read_data_ptr, message_sequence, "1"b /* here or later */,
	     log_message_ptr, code);			/* this recursive call will short-hold the one preserved message */
	if code ^= 0 then do;
	     call log_read_$close (new_log_read_data_ptr, (0));
	     call finished (0);
	end;

	if log_read_data.allocate_copies then		/* held messages cannot be held across an update */
						/* because the copy pointers cannot be preserved */
	     call free_held_messages;

	call log_read_$close (log_read_data_ptr, (0));
	log_read_data_ptr = new_log_read_data_ptr;

	P_log_read_data_ptr = log_read_data_ptr;
	P_log_message_ptr = log_message_ptr;
	call finished (0);
	return;

     end update_procedure;
%page;

short_hold_message:
     procedure (P_message_ptr);

declare  P_message_ptr pointer;
declare  mp pointer;
declare  node_ptr pointer;
declare  prev_node_ptr pointer;

	if P_message_ptr = null () then return;

	if log_read_data.earlier_message.actual_ptr ^= null ()
	then do;
	     call lookup_node (log_read_data.earlier_message.actual_ptr, node_ptr, prev_node_ptr);
	     if node_ptr ^= null ()
	     then call dereference_node (node_ptr, prev_node_ptr);
	     else free log_read_data.earlier_message.copy_ptr -> log_message;
	     log_read_data.earlier_message = null ();	/* in aggregate */
	end;

	log_read_data.earlier_message = log_read_data.latest_message; /* roll over ! */

	mp = P_message_ptr;
	call lookup_node (mp, node_ptr, (null ()));
	if node_ptr ^= null ()
	then do;
	     node_ptr -> log_held_message_node.reference_count = node_ptr -> log_held_message_node.reference_count + 1;
	     log_read_data.latest_message = node_ptr -> log_held_message_node.message;
	end;
	else do;
	     log_read_data.latest_message.actual_ptr = mp;
	     call allocate_copy (mp, log_read_data.latest_message.copy_ptr);
	end;
	P_message_ptr = log_read_data.latest_message.copy_ptr;
	return;
     end short_hold_message;

hold_message:
     procedure (P_message_ptr, P_message_copy_ptr);

declare  P_message_ptr pointer;
declare  P_message_copy_ptr pointer;
declare  mp pointer;
declare  node_ptr pointer;

	mp = P_message_ptr;

	call lookup_node (mp, node_ptr, (null ()));
	if node_ptr = null () then do;
	     node_ptr = new_node ();
	     node_ptr -> log_held_message_node.actual_ptr = mp;
	     node_ptr -> log_held_message_node.copy_ptr = P_message_copy_ptr;
	end;
	node_ptr -> log_held_message_node.reference_count = node_ptr -> log_held_message_node.reference_count + 1;
	return;
     end hold_message;

free_message:
     procedure (P_message_ptr);
declare  P_message_ptr pointer;

declare  mp pointer;
declare  prev_node_ptr pointer;
declare  node_ptr pointer;
declare  next_node_ptr pointer;

	mp = P_message_ptr;
	prev_node_ptr = null ();
	node_ptr = log_read_data.first_held_message_ptr;
	do while (node_ptr ^= null ());
	     if node_ptr -> log_held_message_node.copy_ptr = mp
	     then go to FOUND_NODE;
	     prev_node_ptr = node_ptr;
	     node_ptr = node_ptr -> log_held_message_node.next_ptr;
	end;

	call sub_err_ (0, "log_read_", ACTION_CAN_RESTART, null (), (0), "free_message failed to find message ^p on held list.", mp);
	return;


FOUND_NODE:
DEREFERENCE_COMMON:
	if node_ptr -> log_held_message_node.reference_count > 1
	then do;
	     node_ptr -> log_held_message_node.reference_count = node_ptr -> log_held_message_node.reference_count - 1;
	     return;
	end;


	free node_ptr -> log_held_message_node.copy_ptr -> log_message;
	next_node_ptr = node_ptr -> log_held_message_node.next_ptr;

	if prev_node_ptr ^= null () then prev_node_ptr -> log_held_message_node.next_ptr = next_node_ptr;
	else log_read_data.first_held_message_ptr = prev_node_ptr;
	if log_read_data.last_held_message_ptr = node_ptr
	then log_read_data.last_held_message_ptr = prev_node_ptr;

	free node_ptr -> log_held_message_node;
	return;

dereference_node:
     entry (P_node_ptr, P_prev_node_ptr);

declare  P_node_ptr pointer;
declare  P_prev_node_ptr pointer;

	prev_node_ptr = P_prev_node_ptr;
	node_ptr = P_node_ptr;
	go to DEREFERENCE_COMMON;

     end free_message;

lookup_node: procedure (P_message_ptr, P_node_ptr, P_prev_node_ptr);

declare  (P_message_ptr, P_node_ptr, P_prev_node_ptr) pointer;
declare  (mp, node_ptr, prev_node_ptr) pointer;

	mp = P_message_ptr;
	node_ptr = log_read_data.first_held_message_ptr;
	prev_node_ptr = null ();
	do while (node_ptr ^= null ());
	     if node_ptr -> log_held_message_node.actual_ptr = mp
	     then go to FOUND_NODE;
	     prev_node_ptr = node_ptr;
	     node_ptr = node_ptr -> log_held_message_node.next_ptr;
	end;
	P_node_ptr, P_prev_node_ptr = null ();
	return;

FOUND_NODE:
	P_node_ptr = node_ptr;
	P_prev_node_ptr = prev_node_ptr;
	return;
     end lookup_node;

new_node:
     procedure returns (pointer);

declare  node_ptr pointer;

	system_area_ptr = get_system_free_area_ ();
	allocate log_held_message_node in (system_area) set (node_ptr);
	node_ptr -> log_held_message_node.next_ptr = null ();
	node_ptr -> log_held_message_node.reference_count = 0;

	if log_read_data.first_held_message_ptr = null ()
	then do;
	     log_read_data.first_held_message_ptr,
		log_read_data.last_held_message_ptr = node_ptr;
	     return (node_ptr);
	end;

	log_read_data.last_held_message_ptr -> log_held_message_node.next_ptr = node_ptr;
	log_read_data.last_held_message_ptr = node_ptr;
	return (node_ptr);
     end new_node;

lookup_message:
     procedure (P_copy_ptr) returns (pointer);

declare  node_ptr pointer;
declare  P_copy_ptr pointer;
declare  mp pointer;

	mp = P_copy_ptr;
	if mp = null () then return (null ());
	if mp = log_read_data.latest_message.copy_ptr
	then return (log_read_data.latest_message.actual_ptr);
	if mp = log_read_data.earlier_message.copy_ptr
	then return (log_read_data.earlier_message.actual_ptr);

	node_ptr = log_read_data.first_held_message_ptr;
	do while (node_ptr ^= null ());
	     if mp = node_ptr -> log_held_message_node.copy_ptr
	     then return (node_ptr -> log_held_message_node.actual_ptr);
	     node_ptr = node_ptr -> log_held_message_node.next_ptr;
	end;
	call sub_err_ (error_table_$no_log_message, "log_read_", ACTION_CANT_RESTART, null (), (0), "Invalid message pointer ^p.", mp);
     end lookup_message;

allocate_copy:
     procedure (P_message_ptr, P_copy_ptr);

declare  (P_message_ptr, P_copy_ptr) pointer;
declare  caller_area area based (log_read_data.user_area_ptr);

	log_message_text_lth = P_message_ptr -> log_message.text_lth;
	log_message_data_class_lth = P_message_ptr -> log_message.data_class_lth;
	log_message_data_lth = P_message_ptr -> log_message.data_lth;
	allocate log_message in (caller_area) set (P_copy_ptr);
	P_copy_ptr -> log_message = P_message_ptr -> log_message;
	return;
     end allocate_copy;

free_held_messages:
     procedure;

declare  smp_this pointer;
declare  smp_next pointer;

	if log_read_data.latest_message.actual_ptr ^= null ()
	then do;
	     call lookup_node (log_read_data.latest_message.actual_ptr, smp_this, (null ()));
	     if smp_this = null ()			/* its NOT in the held chain */
	     then free log_read_data.latest_message.copy_ptr -> log_message;
	     log_read_data.latest_message = null ();
	end;

	if log_read_data.earlier_message.actual_ptr ^= null ()
	then do;
	     call lookup_node (log_read_data.earlier_message.actual_ptr, smp_this, (null ()));
	     if smp_this = null ()			/* its NOT in the held chain */
	     then free log_read_data.earlier_message.copy_ptr -> log_message;
	     log_read_data.earlier_message = null ();
	end;

	smp_this = log_read_data.first_held_message_ptr;
	do while (smp_this ^= null ());
	     free smp_this -> log_held_message_node.message.copy_ptr -> log_message;
	     smp_next = smp_this -> log_held_message_node.next_ptr;
	     free smp_this -> log_held_message_node;
	     smp_this = smp_next;
	end;
	return;
     end free_held_messages;
%page;

check_in_pointer:
     procedure;

	log_read_data_ptr = P_log_read_data_ptr;
	if log_read_data_ptr = null ()
	then call sub_err_ (error_table_$null_info_ptr, "log_read_", ACTION_CANT_RESTART, null (), (0), "Null log_read_data_ptr supplied.");
	if log_read_data.sentinel ^= LOG_READ_DATA_VERSION_SENTINEL
	then call sub_err_ (error_table_$badcall, "log_read_", ACTION_CANT_RESTART, null (), (0), "Invalid log_read_data_ptr supplied in call to log_read_.");
	return;
     end check_in_pointer;

finished:
     procedure (P_return_code);

declare  P_return_code fixed bin (35) parameter;


	P_code = P_return_code;
	goto MAIN_RETURN;

     end finished;

/* format: off */
%page; %include log_read_data;
%page; %include log_read_open_info;
%page; %include log_segment;
%page; %include log_message;
%page; %include sub_err_flags;

     end log_read_;




		    log_salvage_.pl1                11/11/89  1059.9r w 11/11/89  0800.0      310347



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

/* format: style4,indattr */

log_salvage_:
     procedure (P_log_dname, P_log_ename, P_salvage_arg_ptr, P_salv_code);

/* *	LOG_SALVAGE_
   *
   *	This user-ring program is responsible for ensuring the log
   *	family is in a usable state.  System crashes at critical times
   *	can cause a variety of disasters (mostly when an ESD is not
   *	completed).  For instance, the "current" log segment may be
   *	found out of service or uninitialized.
   *
   *	Here we check all segments in the primary log directory.  It
   *	is assumed that all other history directories are OK.
   *
   *	NOTE: There is no attempt to lock other processes from modifying
   *	the log.  This routine should be called only when some other means
   *	has been employed to obtain exclusive access to the log.
   *
   *	Suggested usage:
   *	     call log_write_$open (dir, name, "0"b, datap, code);
   *	     if code ^= 0 then do;
   *		unspec (salv_arg) = ""b;
   *		salv_arg.version = LOG_SALVAGE_ARG_VERSION_1;
   *		salv_arg.reporter_proc = print_errors;
   *		call log_salvage_ (dir, name, addr(salv_arg), code);
   *		if salv_code = 0
   *		then call log_write_$open (dir, name, "0"b, datap, code);
   *		if code ^= 0	(* still failing? *)
   *		then call error (code);
   *	     end;
   *
   *	Note that the call to log_write_ has the parameter which controls
   *	log creation set to "0"b.  In cases where it is expected a log
   *	segment already exists, it is best to leave possible re-creation
   *	to log_salvage_.  The log_salvage_ routine will attempt to set the
   *	proper sequence number in a newly created log segment; log_write_
   *	will not.  This is because log_write_ does not have the facility
   *	to interrogate the log history.
   *
   *	Modification History:
   *	85-04-09, EJ Sharpe: initial coding
*/
%page;

/* Parameters */

declare  P_log_dname	  char (*) parameter;	/* Input: log dir path */
declare  P_log_ename	  char (*) parameter;	/* Input: log family name */
declare  P_salvage_arg_ptr	  pointer parameter;	/* Input: controls our behaviour */
declare  P_salv_code	  fixed bin (35) parameter;	/* Output: 0 tells caller to retry open */


/* Automatic */

declare  log_dname		  char (168);		/* arg copy */
declare  log_ename		  char (32);		/* arg copy */
declare  1 auto_log_salvage_arg aligned like log_salvage_arg; /* arg copy */


declare  bit_count		  fixed bin (24);		/* ignored */
declare  code		  fixed bin (35);		/* the usual */
declare  current_log_ptr	  pointer;		/* pointer to current (non-history) log seg */
declare  done		  bit (1) aligned;		/* loop control */
declare  error_found	  bit (1) aligned;		/* found some anomaly */
declare  first_sequence_temp	  fixed bin (35);		/* temp value */
declare  fix_applied	  bit (1) aligned;		/* changed something for the better */
declare  i		  fixed bin;		/* loop control */
declare  history_log_ptr	  pointer;		/* pointer to most recent usable history seg */
declare  n_good_hist_segs	  fixed bin;		/* the number of usable history segs */
declare  newest_hist_log_idx	  fixed bin;		/* index of most recent usable history seg */
declare  next_older_log_idx	  fixed bin;		/* temp idx */
declare  next_older_log_ptr	  pointer;		/* temp ptr */
declare  oldest_hist_log_idx	  fixed bin;		/* index of oldest history log which is usable */
declare  renamed_damaged_log	  bit (1) aligned;		/* set if current log seg damaged */
declare  sequence_problem_detected bit (1) aligned;	/* found problem with history sequencing */


/* Based */

/* NOTE NOTE NOTE - The following structure is copied from log_segment_.  It
   does not exist in an include file because log_segment_ is the only program
   which is supposed to know this format.  */

declare  sequence_info_ptr	  pointer;
declare  1 sequence_info	  aligned based (sequence_info_ptr),
	 2 pad		  bit (17) unal,
	 2 number		  fixed bin (35) unal,	/* spans word boundary!!!!!!! */
	 2 in_service	  bit (1) unal,
	 2 words_used	  fixed bin (18) unsigned unal;


/* External */

declare  error_table_$action_not_performed fixed bin (35) external;
declare  error_table_$bad_arg	  fixed bin (35) external;
declare  error_table_$namedup	  fixed bin (35) external;
declare  error_table_$noentry	  fixed bin (35) external;
declare  error_table_$nomatch	  fixed bin (35) external;
declare  error_table_$no_w_permission fixed bin (35) external;
declare  error_table_$unexpected_condition fixed bin (35) external;
declare  error_table_$unimplemented_version fixed bin (35) external;

declare  log_data_$default_log_size fixed bin (35) external;

declare  sys_info$first_reasonable_time fixed bin (71) external;


/* Entries */

declare  convert_status_code_	  entry (fixed bin (35), char (8) aligned, char (100) aligned);
declare  cu_$arg_ptr	  entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
declare  cu_$level_get	  entry returns (fixed bin);
declare  formline_		  entry options (variable);
declare  get_group_id_	  entry () returns (char (32));
declare  get_process_access_class_ entry () returns (bit (72) aligned);
declare  get_system_free_area_  entry () returns (ptr);
declare  hcs_$chname_file	  entry (char (*), char (*), char (*), char (*), fixed bin (35));
declare  hcs_$chname_seg	  entry (ptr, char (*), char (*), fixed bin (35));
declare  hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
declare  hcs_$list_acl	  entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35));
declare  hcs_$status_for_backup entry (char (*), char (*), pointer, fixed bin (35));
declare  hcs_$status_long	  entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
declare  initiate_file_	  entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
declare  ioa_$rsnpnnl	  entry () options (variable);
declare  log_create_$new_segment entry (ptr, ptr, fixed bin (35));
declare  log_list_history_$single_dir entry (char (*), char (*), ptr, fixed bin (35));
declare  log_name_$name	  entry (char (*), fixed bin (71)) returns (char (32));
declare  log_segment_$initialize_sequence entry (ptr, fixed bin (35), fixed bin (35));
declare  log_segment_$place_in_service entry (ptr, fixed bin (35));
declare  pathname_		  entry (char (*), char (*)) returns (char (168));
declare  terminate_file_	  entry (ptr, fixed bin (24), bit (*), fixed bin (35));
declare  timer_manager_$sleep	  entry (fixed bin (71), bit (2));
declare  unique_bits_	  entry () returns (bit (70));
declare  unique_chars_	  entry (bit (*)) returns (char (15));


/* Misc */

declare  NUM_GOOD_HIST_DESIRED  fixed bin init (5) internal static options (constant);
declare  ONE_SECOND		  fixed bin (71) init (1000000) internal static options (constant);
declare  RELATIVE_MICROSECONDS  bit (2) init ("10"b) internal static options (constant);

declare  any_other		  condition;
declare  cleanup		  condition;
declare  no_write_permission	  condition;
declare  seg_fault_error	  condition;

declare  abs		  builtin;
declare  addr		  builtin;
declare  clock		  builtin;
declare  length		  builtin;
declare  null		  builtin;
declare  rtrim		  builtin;
declare  size		  builtin;
declare  substr		  builtin;
%page;

/* MAIN CODE */

/* Here's the plan:

   Somehow log_write_ has failed to open the log, or we're being called just to
   check up on things.  We will deal only with the log segments in the primary
   log directory.  We won't try going off to other directories in search of older
   family members.

   The first step will be to get a list of the history logs in the directory
   (i.e.  those with the name LOGNAME.??????.????).  This list will be used to
   look at the last few segments or back to salvage_args.from_time.  Each seg
   will be initiated and its header inspected.  Any errors will be reported.  The
   log_read_data structure will be used to keep track of those found "good" (the
   "ptr" element will be set non-null).

   The next step will be to check the good history segments for consistant
   sequence numbers.  Any inconsistancies will be reported (a future enhancement
   will be to automatically adjust the sequence numbers).

   Finally, the current log segment "LOG_NAME" will be checked.  If we're
   supposed to migrate segments to this log, this segment should not exist.
   Otherwise, we have to make sure the segment is there and usable.  If there's
   some problem the segment will be renamed to "LOG_NAME.!(unique)" and a new one
   created.  Some checks are made to ensure the sequence numbers are consistant
   between the current log segment and the history.
*/

/* Setup. */

	error_found = "0"b;				/* this will get set if we find a proble, */
	fix_applied = "0"b;				/* this will get set if we change something */

	log_read_data_ptr = null ();
	history_log_ptr = null ();
	oldest_hist_log_idx = 0;
	newest_hist_log_idx = 0;
	current_log_ptr = null ();
	renamed_damaged_log = "0"b;

	/*** copy args */
	log_dname = P_log_dname;
	log_ename = P_log_ename;
	log_salvage_arg_ptr = P_salvage_arg_ptr;
	auto_log_salvage_arg = log_salvage_arg;
	log_salvage_arg_ptr = addr (auto_log_salvage_arg);

	if log_salvage_arg.version ^= LOG_SALVAGE_ARG_VERSION_1
	then call Finished (error_table_$unimplemented_version);

	if log_salvage_arg.from_time ^= 0
	then if log_salvage_arg.from_time > clock ()
		| log_salvage_arg.from_time < sys_info$first_reasonable_time
	     then call Finished (error_table_$bad_arg);

	on cleanup call Cleanup;


/* Get a list of the history segments (in the primary log directory) for this
   log. */

	call log_list_history_$single_dir (log_dname, log_ename, log_read_data_ptr, code);
	if code = error_table_$nomatch
	then goto SKIP_HISTORY;
	if code ^= 0 then do;
	     call Report_Error (code, "Unable to list ""^a"" log segments in ^a.", log_ename, log_dname);
	     call Finished (code);
	end;


/* Here we'll initiate the latest log history segments (excluding the damaged
   ones).  The number of segments to initiate is determined by
   log_salvage_arg.from_time (but at least one).  If zero, then we'll initiate
   the last NUM_GOOD_HIST_DESIRED segments. */

	n_good_hist_segs = 0;
	done = "0"b;
	do i = 1 to log_read_data.n_segments while (^done);
	     call Initiate_History_Segment_and_Check (i); /* will remove damaged ones from list */
	     if log_read_data.segments (i).ptr ^= null () /* will be null if seg is damaged in some way */
	     then do;
		n_good_hist_segs = n_good_hist_segs + 1;
		if n_good_hist_segs = 1		/* first one? */
		then newest_hist_log_idx = i;		/* remember it */
		oldest_hist_log_idx = i;		/* and the  last one */
	     end;
	     if log_salvage_arg.from_time > 0
	     then done = (log_read_data.segments (i).suffix_time <= log_salvage_arg.from_time);
	     else done = n_good_hist_segs >= NUM_GOOD_HIST_DESIRED;
	end;
	if n_good_hist_segs = 0 then goto SKIP_HISTORY;


/* At this point newest_hist_log_idx and oldest_hist_log_idx define the range
   of log segments we're interested in investigating further.  There may be some
   in-between that are damaged, so we have to be careful to make sure we have the
   pointer.  */

/* We'll check their sequence numbers to make sure they agree with the time
   stamps on the segment names (i.e.  they must be ascending).  */

	sequence_problem_detected = "0"b;
	next_older_log_ptr = log_read_data.segments (oldest_hist_log_idx).ptr;
	next_older_log_idx = oldest_hist_log_idx;
	do i = (oldest_hist_log_idx - 1) to newest_hist_log_idx by -1;
	     log_segment_ptr = log_read_data.segments (i).ptr;
	     if log_segment_ptr ^= null ()
	     then do;
		if log_segment.first_sequence <= next_older_log_ptr -> log_segment.last_sequence then do;
		     call Report_Error (0, "Sequence conflict in ""^a"" with ""^a"".",
			log_read_data.segments (i).ename, log_read_data.segments (next_older_log_idx).ename);
		     sequence_problem_detected = "1"b;
		end;
		next_older_log_ptr = log_segment_ptr;
		next_older_log_idx = i;
	     end;
	end;


	/*** The following is for future implementation; right now we'll have only the
	     error messages, no fixes.

	     if log_salvage_arg.flags.adjust_history_sequence & sequence_problem_detected
	     then call Fix_History_Sequence;
	*/


/* OK, checking of the log history is done.  Now we deal with the current log
   segment.  */

SKIP_HISTORY:
	call initiate_file_ (log_dname, log_ename, RW_ACCESS, current_log_ptr, bit_count, code);
	if code = error_table_$noentry then do;
	     if ^log_salvage_arg.flags.migrating
	     then do;
		call Create_New_Log_Seg (null ());	/* create a new one for 'em */
		call Finished (0);
	     end;
	     else call Finished (0);			/* thats how it should be */
	end;
	else if code = 0 then do;
	     if ^log_salvage_arg.flags.migrating
	     then do;
		if ^Check_Log_Segment (current_log_ptr, log_ename, "1"b)
		then do;
		     call Rename_as_Damaged (log_dname, log_ename);
		     call Create_New_Log_Seg (current_log_ptr);
		     call Finished (0);
		end;
	     end;
	     else do;
		call Report_Error (0, "Found history log without timestamp ""^a"".", log_ename);
		if ^Check_Log_Segment (current_log_ptr, log_ename, "0"b)
		then do;
		     call Rename_as_Damaged (log_dname, log_ename);
		     call Finished (0);
		end;
		else call Rename_for_Last_Message (current_log_ptr, log_ename); /* make it a history log segment */
	     end;
	end;
	else do;					/* totally unexpected code, treat 'em as damaged */
	     call Report_Error (code, "^a", pathname_ (log_dname, log_ename));
	     call Rename_as_Damaged (log_dname, log_ename);
	     if ^log_salvage_arg.flags.migrating
	     then call Create_New_Log_Seg (null ());
	     call Finished (0);
	end;


/* We end up here only if a current seg existed.  The last check is
   to make sure the sequence succeeds the most recent history
   segment.  */

	if n_good_hist_segs = 0			/* but not if there was no history... */
	then call Finished (0);

	history_log_ptr = log_read_data.segments (newest_hist_log_idx).ptr;
	if history_log_ptr ^= null ()			/* do we have at least one history seg? */
	then do;
	     if current_log_ptr -> log_segment.first_sequence ^= 0
	     then first_sequence_temp = current_log_ptr -> log_segment.first_sequence;
	     else do;
						/* get first sequence number from the alloc info */
		sequence_info_ptr = addr (current_log_ptr -> log_segment.alloc_info);
		first_sequence_temp = sequence_info.number;
	     end;
	     if first_sequence_temp <= history_log_ptr -> log_segment.last_sequence
	     then do;
		call Report_Error (0, "Sequence conflict in ""^a"" with ""^a"".",
		     log_ename, log_read_data.segments (newest_hist_log_idx).ename);
		call Rename_as_Damaged (log_dname, log_ename);
		if ^log_salvage_arg.migrating
		then call Create_New_Log_Seg (current_log_ptr);
		call Finished (0);
	     end;
	end;
	else do;
	     /*** We don't have any log history ptr, but we still want to
		make sure the sequence numbers seem appropriate.  Thus,
		if there was any history segment (damaged or inaccessable)
		we'll make sure the present log does not start at the
		beginning of the sequence.  log_segment_ starts all logs
		at 1000000 (1 million), if this one starts there, and
		there are history segs, the sequence was restarted somehow.
		Unfortunately, there's no way to determine what the real
		sequence numbers should be.  ***/
	     if log_read_data.n_segments > 0 & log_segment.first_sequence < 1000001
	     then do;
		call Report_Error (0, "Sequence was restarted.");
		call Finished (0);
	     end;
	end;

	call Finished (0);
%page;

/* *
   *	FINISHED
   *
   *	This is the exit procedure.  The cleanup procedure is called, and
   *	a little editing is done on the returned code.  We want to be sure
   *	to return 0 if we didn't encounter a fatal error AND we actually
   *	were of some help.  If there was nothing we could do, we return
   *	error_table_$action_not_performed.  This tell's our caller that
   *	it is useless to retry the log_write_$open operation.
   *
*/

Finished:
     procedure (P_code);

declare  P_code		  fixed bin (35) parameter;

	call Cleanup;

	if fix_applied
	then P_salv_code = P_code;
	else if P_code = 0
	then P_salv_code = error_table_$action_not_performed;
	else P_salv_code = P_code;

	goto MAIN_RETURN;

     end Finished;

MAIN_RETURN:
	return;
%page;

/* *
   *	CLEANUP
   *
   *	Terminate any initiated segs, and free allocated storage.
   *
*/

Cleanup:
     procedure;

declare  p		  pointer;		/* local scratch pointer */

	if log_read_data_ptr ^= null
	then do;
	     do i = 1 to log_read_data.n_segments;
		if log_read_data.segments (i).ptr ^= null ()
		then do;
		     p = log_read_data.segments (i).ptr;
		     log_read_data.segments (i).ptr = null ();
		     call terminate_file_ (p, 0, TERM_FILE_TERM, (0));
		end;
	     end;
	     free log_read_data;
	     log_read_data_ptr = null ();
	end;

	if current_log_ptr ^= null ()
	then do;
	     p = current_log_ptr;
	     current_log_ptr = null ();
	     call terminate_file_ (p, 0, TERM_FILE_TERM, (0));
	end;

     end Cleanup;
%page;

/* *
   *	REPORT_ERROR
   *	REPORT_FIX
   *
   *	This routine is called whenever there is anything to say.  The
   *	reporter procedure specified in log_salvage_arg is used to
   *	print (or whatever pleases it) the message.
   *
   *	Also, this is where flags are set indicating whether any errors
   *	were detected, and whether any fixes were applied.
   *
*/

Report_Error:
     procedure options (variable);

declare  arg_code		  fixed bin (35) based (argp);
declare  argl		  fixed bin (21);		/* ignored */
declare  argp		  pointer;

declare  ecode		  fixed bin (35);
declare  ignore_short_mess	  char (8) aligned;		/* ignored */
declare  long_mess		  char (100) aligned;	/* expanded status code */

declare  msg		  char (msg_len) based (msg_ptr);
declare  msg_buff		  char (512);
declare  msg_len		  fixed bin (21);
declare  msg_ptr		  pointer;

declare  complete_msg	  char (complete_msg_len) based (complete_msg_ptr);
declare  complete_msg_buff	  char (614);		/* 102 chars bigger than msg_buff */
declare  complete_msg_len	  fixed bin (21);
declare  complete_msg_ptr	  pointer;

	error_found = "1"b;				/* so we remember we found some anomaly */
	goto REPORT_COMMON;

Report_Fix:
     entry options (variable);

	fix_applied = "1"b;				/* so we remember we did something */

REPORT_COMMON:

	call cu_$arg_ptr (1, argp, argl, ecode);	/* get arg_code */
	if ecode ^= 0
	then call Finished (ecode);

	ecode = arg_code;				/* copy our arg */

	/*** first format the message passed to us */
	msg_ptr = addr (msg_buff);
	msg_len = size (msg_buff);
	call formline_ (2, 3, addr (msg_buff), msg_len, 0 /* no pad */);

	/*** second, expand the error code */
	if ecode ^= 0
	then do;
	     call convert_status_code_ (ecode, ignore_short_mess, long_mess);
	     complete_msg_ptr = addr (complete_msg_buff);
	     complete_msg_len = length (complete_msg_buff);
	     call ioa_$rsnpnnl ("^a  ^a", complete_msg_buff, complete_msg_len, long_mess, msg);
	end;
	else do;
	     /*** This is all we have... */
	     complete_msg_ptr = msg_ptr;
	     complete_msg_len = msg_len;
	end;

	/*** finally, call the reporting procedure.
	     This procedure will be responsible for adding the frosting on
	     the messages (i.e. name of procedure generating the message,
	     pathname of log we're salvaging, process group id, etc). */

	on any_other call Finished (error_table_$unexpected_condition);
	call log_salvage_arg.reporter_proc (complete_msg);

	return;

     end Report_Error;
%page;

/* *
   *	INITIATE_HISTORY_SEGMENT_AND_CHECK
   *
   *	This routine initiates a log history segment.  The first attempt is
   *	made requesting RW access.  If that fails, a second attempt is made
   *	requesting only R access.  Having only R access becomes a problem
   *	only if the service bit will need to be turned off (and, in the
   *	future, if the sequence numbers need adjustment).  Any code in
   *	log_salvage_ which tries to modify a history segment must be
   *	prepared to take an access violation fault.
   *
*/

Initiate_History_Segment_and_Check:
     procedure (P_log_idx);

declare  P_log_idx		  fixed bin;		/* index into log_read_data */

declare  log_idx		  fixed bin;

declare  ecode		  fixed bin (35);
declare  log_ptr		  pointer;

	log_idx = P_log_idx;
	call initiate_file_ (log_dname, log_read_data.segments (log_idx).ename, RW_ACCESS, log_ptr, bit_count, ecode);
	if ecode = error_table_$no_w_permission
	then do;
	     /*** We'll try it with just read access, the rest of
		this routine can deal with access violation faults. */
	     call initiate_file_ (log_dname, log_read_data.segments (log_idx).ename, R_ACCESS, log_ptr, bit_count, ecode);

	     if ecode = 0				/* report an error in either case */
	     then call Report_Error (error_table_$no_w_permission, "^a", log_read_data.segments (log_idx).ename);
	     else call Report_Error (ecode, "^a", log_read_data.segments (log_idx).ename);
	end;

	if ^Check_Log_Segment (log_ptr, log_read_data.segments (log_idx).ename, "0"b)
	then log_ptr = null ();			/* don't want to use this guy */

	log_read_data.segments (log_idx).ptr = log_ptr;	/* it may still be null */

	return;

     end Initiate_History_Segment_and_Check;
%page;

/* *
   *	CHECK_LOG_SEGMENT
   *
   *	This routine checks consistancy within a single log segment.
   *	Sequence numbers and times in the header must be consistant
   *	in respect to one another.  The service bit must be off for
   *	history segs, on for the live seg (it is adjusted if necessary).
   *	Also, the first message sentinel is checked.
   *
*/

Check_Log_Segment:
     procedure (P_log_ptr, P_log_name, P_current_log) returns (bit (1) aligned);

declare  P_log_ptr		  pointer parameter;
declare  P_log_name		  char (32) parameter;
declare  P_current_log	  bit (1) aligned parameter;

declare  lp		  pointer;
declare  lname		  char (32);
declare  current_log	  bit (1) aligned;


	lp = P_log_ptr;
	lname = P_log_name;
	current_log = P_current_log;

	on seg_fault_error begin;			/* watch out for damaged segs */
	     call Report_Error (0, "Seg Fault Error while checking ^a.  Segment may be damaged.", lname);
	     goto CHECK_LOG_SEG_EXIT;
	end;

	on any_other begin;
	     call Report_Error (0, "Unexpected condition encountered while checking log segment ^a.", lname);
	     goto CHECK_LOG_SEG_EXIT;
	end;

	if lp -> log_segment.version = LOG_SEGMENT_VERSION_1
	then if lp -> log_segment.time_created > sys_info$first_reasonable_time
		& lp -> log_segment.time_created <= clock ()
	     then if lp -> log_segment.first_sequence <= lp -> log_segment.last_sequence
		     & (lp -> log_segment.first_sequence >= 1000000 | lp -> log_segment.first_sequence = 0)
		then if lp -> log_segment.first_time <= lp -> log_segment.last_time
			& lp -> log_segment.last_time <= clock ()
		     then return (Check_Alloc_Info_and_Messages ());

	call Report_Error (0, "Internal header problem in seg ^a.", lname);
CHECK_LOG_SEG_EXIT:
	return ("0"b);



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

declare  flip_service_bit	  bit (1) aligned;
declare  service_bit	  bit (1) aligned;


	     flip_service_bit = "0"b;
	     sequence_info_ptr = addr (lp -> log_segment.alloc_info);
	     service_bit = sequence_info.in_service;	/* compiler will have an easier time with it here */

	     if current_log & ^service_bit		/* checking current seg? */
	     then do;
		call Report_Error (0, "Current log ^a found out of service.", lname);
		flip_service_bit = "1"b;		/* will fix it if nothing else wrong */
	     end;

	     if ^current_log & service_bit		/* checking history seg? */
	     then do;
		call Report_Error (0, "History log ^a found in service.", lname);
		flip_service_bit = "1"b;		/* will fix it if nothing else wrong */
	     end;


	     if abs (sequence_info.number - lp -> log_segment.last_sequence) > 3 & lp -> log_segment.first_sequence > 0
	     then do;
		call Report_Error (0, "Last sequence and ""real"" sequence disagree in ^a.", lname);
		goto return_failure;
	     end;

	     if sequence_info.words_used > lp -> log_segment.max_size
	     then do;
		call Report_Error (0, "Words used inconsistant with max size in ^a.", lname);
		goto return_failure;
	     end;



/* Check the first message. */

	     if lp -> log_segment.first_sequence = 0	/* but not if there's none there */
	     then goto return_success;

	     log_message_ptr = addr (lp -> log_segment.data); /* get to first message */
	     if log_message.sentinel ^= LOG_SEGMENT_NEW_MESSAGE
		& log_message.sentinel ^= LOG_SEGMENT_COMPLETE_MESSAGE
	     then do;
		call Report_Error (0, "First message invalid in ^a.", lname);
		goto return_failure;
	     end;


/* We might consider going through all the messages, but it seems a waste.  If
   the first one is there intact, log_position_ will be able to handle any other
   problem.  */


return_success:
	     if flip_service_bit
	     then do;
		on no_write_permission goto return_failure; /* may happen here */
		sequence_info.in_service = ^service_bit;
		revert no_write_permission;
		call Report_Fix (0, "Service bit set ^[on^;off^] in ^a.", ^service_bit, lname);
	     end;
	     return ("1"b);

return_failure:
	     return ("0"b);

	end Check_Alloc_Info_and_Messages;

     end Check_Log_Segment;
%page;

/* *
   *	CREATE_NEW_LOG_SEGMENT
   *
   *	This routine is invoked if there is no live log segment, or if
   *	the live log segment has internal damages.  If the immediately
   *	previous history segment is available, the sequence numbers
   *	in the new segment may be set correctly.  However, if there
   *	is no history, or it is damaged, an estimated sequence number
   *	is calculated.
   *
   *	If some history segment is available, the access list and other
   *	file system attributes are copied from that history segment to
   *	the newly created segment.
   *
*/

Create_New_Log_Seg:
     procedure (P_old_log_ptr);

declare  P_old_log_ptr	  pointer parameter;

declare  old_logp		  pointer;

declare  acl_ptr		  pointer;
declare  acl_count		  fixed bin;
declare  code		  fixed bin (35);
declare  hist_log_name	  char (32);
declare  max_len		  fixed bin (19);
declare  n_logs_unseen	  fixed bin;
declare  new_log_ptr	  pointer;
declare  new_sequence	  fixed bin (35);
declare  system_area	  area based (system_area_ptr);
declare  system_area_ptr	  pointer;

declare  1 auto_log_segment_info aligned like log_segment_info;
declare  1 status		  aligned like status_branch;
declare  1 sfb		  aligned like status_for_backup;


	system_area_ptr = null ();
	acl_ptr = null ();
	acl_count = 0;
	old_logp = P_old_log_ptr;

	on cleanup call create_new_log_seg_cleanup ();
	on any_other begin;
	     call Report_Error (0, "Unexpected error while creating new log segment.");
	     goto CREATE_NEW_LOG_SEG_EXIT;
	end;

/* This procedure mimicks the way log_write_ would create a new log segment.
   That is, it attempts to set up the sequence such that it follows the history.
   However, in this case the most recent history segment may not be available.
   In that case we'll estimate what the next sequence number should be based upon
   the number of history logs we can't see.  */

	if log_read_data.n_segments = 0
	then new_sequence = 1000000;			/* start it a a million */
	else do;
	     if n_good_hist_segs = 0
	     then n_logs_unseen = log_read_data.n_segments; /* account for its possible sequence numbers */
	     else n_logs_unseen = newest_hist_log_idx - 1;/* account for sequence
						   numbers of history logs we can't look at */
	     if renamed_damaged_log			/* was current log damaged? */
	     then n_logs_unseen = n_logs_unseen + 1;	/* account for its sequence numbers too */

	     if n_good_hist_segs = 0
	     then					/* new sequence is based on number of logs in history */
		new_sequence = 1000000 + (n_logs_unseen * 100000) + 1;
	     else					/* new sequence is based on number of history logs we can't
						   see and the last sequence number we can see. */
		new_sequence = log_read_data.segments (newest_hist_log_idx).ptr ->
		     log_segment.last_sequence + (n_logs_unseen * 100000) + 1;
	end;

	/*** set up default info about the new segment */
	log_segment_info_ptr = addr (auto_log_segment_info);
	log_segment_info.dname = log_dname;
	log_segment_info.ename = log_ename;
	log_segment_info.acl_ptr = null ();
	log_segment_info.acl_count = 0;
	log_segment_info.rings (*) = cu_$level_get ();
	log_segment_info.max_length = log_data_$default_log_size;
	log_segment_info.access_class = get_process_access_class_ ();
	log_segment_info.multi_class = "0"b;
	log_segment_info.effective_mode = RW_ACCESS;

	/*** we may be able to get more precise info */
	if newest_hist_log_idx ^= 0
	then do;
	     hist_log_name = log_read_data.segments (newest_hist_log_idx).ename;
	     sfb.version = status_for_backup_version_2;
	     call hcs_$status_for_backup (log_dname, hist_log_name, addr (sfb), code);
	     if code = 0
	     then do;
		log_segment_info.multi_class = sfb.multiple_class;
		log_segment_info.access_class = sfb.access_class;
	     end;

	     call hcs_$status_long (log_dname, hist_log_name, 1, addr (status), null (), code);
	     if code = 0
	     then do;
		log_segment_info.effective_mode = substr (status.mode, 2, 3);
		log_segment_info.rings (*) = status.ring_brackets (*);
	     end;

	     system_area_ptr = get_system_free_area_ ();
	     call hcs_$list_acl (log_dname, hist_log_name, system_area_ptr, acl_ptr, null (), acl_count, code);
	     if code = 0
	     then do;
		log_segment_info.acl_ptr = acl_ptr;
		log_segment_info.acl_count = acl_count;
	     end;

	     call hcs_$get_max_length_seg (log_read_data.segments (newest_hist_log_idx).ptr, max_len, code);
	     if code = 0
	     then do;
		log_segment_info.max_length = max_len;
	     end;
	end;

	new_log_ptr = null ();
	call log_create_$new_segment (log_segment_info_ptr, new_log_ptr, code);
	if code ^= 0
	then do;
	     call Report_Error (code, "Unable to create new log segment.");
	     call Finished (code);
	end;
	else do;
	     call Report_Fix (0, "Created new log segment.");
	     call log_segment_$initialize_sequence (new_log_ptr, new_sequence, code);
	     if code ^= 0
	     then call Report_Error (code, "Error initializing sequence in new log segment.");
	     call log_segment_$place_in_service (new_log_ptr, code);
	     if code ^= 0
	     then call Report_Error (code, "Error placing new log segment in service.");
	     call terminate_file_ (old_logp, 0, TERM_FILE_TERM, code);
	     if code ^= 0
	     then call Report_Error (code, "Error terminating old log pointer.");
	     P_old_log_ptr = new_log_ptr;		/* change caller's pointer */
	end;

CREATE_NEW_LOG_SEG_EXIT:
	call create_new_log_seg_cleanup ();

	return;

create_new_log_seg_cleanup:
	procedure;

declare  based_word		  bit (36) based;

	     if acl_ptr ^= null ()
	     then do;
		/*** The runtime support for areas will know how
		     much to actually free. ***/
		free acl_ptr -> based_word in (system_area);
	     end;

	end create_new_log_seg_cleanup;

     end Create_New_Log_Seg;
%page;

/* *
   *	RENAME_AS_DAMAGED
   *
   *	This routine is invoked when the live log segment is found to
   *	have internal inconsistancies or cannot be initiated.  It changes
   *	the name to LOG_NAME.!(unique).  It happens that a unique character
   *	string and the standard timestamp suffix ("YYYYMMDD.HHMMSS") are the
   *	same length.  Thus, we need not worry about truncation of the name
   *	and namedup errors.
   *
*/

Rename_as_Damaged:
     procedure (P_log_dir, P_log_name);

declare  P_log_name		  char (32) parameter;
declare  P_log_dir		  char (168) parameter;

declare  lname		  char (32);
declare  ldir		  char (168);

declare  new_name		  char (32);
declare  code		  fixed bin (35);

	lname = P_log_name;
	ldir = P_log_dir;
	new_name = rtrim (P_log_name) || "." || unique_chars_ (unique_bits_ ());
	call hcs_$chname_file (ldir, lname, lname, new_name, code);
	if code = 0
	then do;
	     renamed_damaged_log = "1"b;
	     call Report_Fix (0, "Changed name of damaged log segment ^a to ^a.", lname, new_name);
	end;
	else call Report_Error (code, "Unable to change name of damaged log segment ^a to ^a.", lname, new_name);

	return;

     end Rename_as_Damaged;
%page;

/* *
   *	RENAME_FOR_LAST_MESSAGE
   *
   *	This routine is invoked when a live log segment is found in a
   *	directory to which we are trying to perform a log migratation.
   *	It places the standard timestamp suffix on the name of the log.
   *
*/

Rename_for_Last_Message:
     procedure (P_log_ptr, P_log_name);

declare  P_log_name		  char (32) parameter;
declare  P_log_ptr		  pointer parameter;

declare  lname		  char (32);
declare  log_ptr		  pointer;

declare  name_time		  fixed bin (71);
declare  new_name		  char (32);
declare  code		  fixed bin (35);
declare  i		  fixed bin;

	lname = P_log_name;
	log_ptr = P_log_ptr;

	if log_ptr -> log_segment.last_time = 0
	then name_time = clock ();
	else name_time = log_ptr -> log_segment.last_time;

	do i = 1 to 10;
	     new_name = log_name_$name (lname, name_time);

	     call hcs_$chname_seg (log_ptr, lname, new_name, code);
	     if code = error_table_$namedup
	     then do;
		name_time = name_time + ONE_SECOND;
		if name_time > clock ()
		then call timer_manager_$sleep (ONE_SECOND, RELATIVE_MICROSECONDS);
	     end;
	     else if code = 0
	     then do;
		call Report_Fix (0, "Renamed log segment ^a to ^a.", lname, new_name);
		return;
	     end;
	     else goto CANNOT_RENAME;			/* unexpected code */
	end;

CANNOT_RENAME:
	call Report_Error (code, "Unable to rename log segment ^a to ^a.", lname, new_name);

	return;

     end Rename_for_Last_Message;

/* format: off */
%page; %include log_salvage_arg;
%page; %include log_segment;
%page; %include log_message;
%page; %include log_read_data;
%page; %include log_write_data;
%page; %include access_mode_values;
%page; %include terminate_file;
%page; %include status_structures;
%page; %include status_for_backup;
%page; %include syserr_constants;

     end log_salvage_;




		    log_write_.pl1                  11/11/89  1059.9rew 11/11/89  0800.0      248823



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

/* format: style4 */

log_write_:
     procedure ();

/* *	LOG_WRITE_
   *
   *	This is the user-ring program responsible for writing messages into a
   *	family of log segments. It keeps track (in log_write_data) of the
   *	current log, and switches log segments when it finds one full.
   *
   *	Modification history:
   *	84-05-29, W. Olin Sibert: Initial coding
   *	84-08-25, WOS: Added $open_for_migrate and related changes
   *	84-10-16, WOS: Changed to rename segments with suffix of last message time
   *	84-10-19, WOS: Changed to ignore segnamedup when renaming logs.
   *	84-12-21, WOS: Changed to handle uninitialized logs better.
   *	84-12-21, WOS: Changed data_class to 16 chars like it should be
   *      84-12-23, WOS: Changed to create segments with suffixes when migrating
   *	85-01-17, GMP: Changed to create segments with the proper access class
   *	85-03-03, EJ Sharpe: Changed name of entry in log_list_history_ from single_dir to
   *		single_dir_oldest_and_newest, added format
   *	85-03-27, EJ Sharpe: get masked for sleeping and for swapping to new log segment,
   *		open now fails if log is not in service
*/

declare  P_log_write_data_ptr pointer parameter;		/* Input: control information */

declare  P_log_dname char (*) parameter;		/* Input: Log dname/ename when opening */
declare  P_log_ename char (*) parameter;
declare  P_create_sw bit (1) aligned parameter;		/* Input: Whether to create, at open, default log */

declare  P_severity fixed bin parameter;		/* Input: Log message severity */
declare  P_message char (*) parameter;			/* Input: Text message */
declare  P_data_ptr pointer parameter;			/* Input: Binary data message location, size, class and type */
declare  P_data_lth fixed bin parameter;		/* Input: Length of data message */
declare  P_data_class char (16) varying parameter;	/* Input: Class of data message */
declare  P_sequence fixed bin (35) parameter;		/* Input: Special sequence for $general */
declare  P_message_lth fixed bin parameter;		/* Input: Length of text portion */
declare  P_log_message_ptr pointer parameter;		/* Output: Location of written message */
declare  P_code fixed bin (35) parameter;		/* Output: Status code */

declare  code fixed bin (35);
declare  open_for_migrate bit (1) aligned;
declare  log_segment_damaged bit (1) aligned;
declare  log_not_initialized bit (1) aligned;
declare  service_bit bit (1) aligned;
declare  system_area_ptr pointer;
declare  system_area area based (system_area_ptr);
declare  based_word bit (36) aligned based;
declare  based_page (1024) bit (36) aligned based;

/* Variables associated with mask manipulation.  Note that
   initializations are assumed by cleanup handler. */
dcl  ipc_mask_code fixed bin (35) init (-1);
dcl  ipc_unmask_code fixed bin (35) init (-1);
dcl  mask bit (36) aligned init (""b);

declare  1 message_info aligned automatic,		/* Description of message being added */
	 2 time fixed bin (71),			/* Set for: $message, $data */
	 2 process_id bit (36) aligned,		/* Set for: $message, $data */
	 2 severity fixed bin (35),			/* Set for: $message, $data */
	 2 text_lth fixed bin,			/* Set for: $message, $data, $general */
	 2 text_ptr pointer,			/* Set for: $message, $data */
	 2 data_lth fixed bin,			/* Set for: $data, $general */
	 2 data_ptr pointer,			/* Set for: $data */
	 2 data_class char (16) varying,		/* Set for: $data, $general */
	 2 sequence fixed bin (35);			/* Set for: $general */

declare  message_text char (message_info.text_lth) unaligned based (message_info.text_ptr);
declare  message_data dim (message_info.data_lth) bit (36) aligned based (message_info.data_ptr);

declare  log_data_$default_log_size fixed bin (35) external static;

declare  error_table_$log_out_of_service fixed bin (35) external static;
declare  error_table_$log_segment_damaged fixed bin (35) external static;
declare  error_table_$log_segment_full fixed bin (35) external static;
declare  error_table_$log_segment_invalid fixed bin (35) external static;
declare  error_table_$log_uninitialized fixed bin (35) external static;
declare  error_table_$namedup fixed bin (35) external static;
declare  error_table_$noentry fixed bin (35) external static;
declare  error_table_$nomatch fixed bin (35) external static;
declare  error_table_$no_w_permission fixed bin (35) external static;
declare  error_table_$segnamedup fixed bin (35) external static;

declare  cu_$level_get entry () returns (fixed bin (3));
declare  get_process_access_class_ entry () returns (bit (72) aligned);
declare  get_process_id_ entry () returns (bit (36) aligned);
declare  get_system_free_area_ entry () returns (pointer);
declare  hcs_$chname_seg entry (pointer, char (*), char (*), fixed bin (35));
declare  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
declare  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
declare  hcs_$terminate_noname entry (pointer, fixed bin (35));
declare  ipc_$mask_ev_calls entry (fixed bin (35));
declare  ipc_$unmask_ev_calls entry (fixed bin (35));
declare  log_create_$duplicate_segment entry (pointer, char (*), char (*), pointer, pointer, fixed bin (35));
declare  log_create_$get_info entry (pointer, pointer, fixed bin (35));
declare  log_create_$new_segment entry (pointer, pointer, fixed bin (35));
declare  log_initialize_ entry (pointer, pointer, fixed bin (18), char (*), fixed bin (35));
declare  log_initiate_ entry (char (*), char (*), fixed bin, pointer, fixed bin (35));
declare  log_list_history_$single_dir_oldest_and_newest entry (char (*), char (*), char (*), char (*), fixed bin, fixed bin (35));
declare  log_name_$name entry (char (*), fixed bin (71)) returns (char (32));
declare  log_segment_$create_message entry (pointer, fixed bin, fixed bin, char (16) varying, pointer, fixed bin (35));
declare  log_segment_$create_message_number entry
	    (pointer, fixed bin, fixed bin, char (16) varying, fixed bin (35), pointer, fixed bin (35));
declare  log_segment_$finish_message entry (pointer, pointer, fixed bin (35));
declare  log_segment_$get_service_bit entry (ptr, bit (1) aligned, fixed bin (35));
declare  log_segment_$place_in_service entry (pointer, fixed bin (35));
declare  log_segment_$remove_from_service entry (pointer, fixed bin (35));
declare  log_wakeup_$send_wakeups entry (pointer, pointer, fixed bin (35));
declare  sub_err_ entry options (variable);
declare  timer_manager_$sleep entry (fixed bin (71), bit (2));

declare  seg_fault_error condition;

declare  WHOAMI char (32) internal static options (constant) init ("log_write_");
declare  MAX_TRIES fixed bin internal static options (constant) init (10);
declare  RELATIVE_MICROSECONDS bit (2) internal static options (constant) init ("10"b);
declare  ONE_SECOND fixed bin (71) internal static options (constant) init (1000000);
declare  ONE_QUARTER_SECOND fixed bin (71) internal static options (constant) init (250000);

declare  cleanup condition;

declare  (addr, clock, length, null, substr, unspec) builtin;
%page;

MAIN_RETURN:
	return;


finished:
     procedure (P_return_code);

declare  P_return_code fixed bin (35) parameter;


	call CLEANUP;
	P_code = P_return_code;
	goto MAIN_RETURN;
     end finished;



abort_open:
     procedure (P_error_code);

declare  P_error_code fixed bin (35) parameter;


	call log_write_$close (log_write_data_ptr, (0));
	call finished (P_error_code);

     end abort_open;





MASK:
     procedure ();

	call hcs_$set_ips_mask (""b, mask);		/* mask ips interrupts */
	call ipc_$mask_ev_calls (ipc_mask_code);	/* mask ipc calls */

     end MASK;


UNMASK:
     procedure ();

	call ipc_$unmask_ev_calls (ipc_unmask_code);
	ipc_mask_code = -1;
	ipc_unmask_code = -1;
	call hcs_$reset_ips_mask (mask, mask);

     end UNMASK;



CLEANUP: procedure;

/* put masks back the way we found 'em and reset variables so we don't try it twice */

	if ipc_mask_code ^= -1 & ipc_unmask_code = -1 then
	     call ipc_$unmask_ev_calls (ipc_unmask_code);
	ipc_mask_code = -1;
	ipc_unmask_code = -1;

	if substr(mask, 36, 1) = "1"b then
	     call hcs_$reset_ips_mask (mask, mask);

     end CLEANUP;
%page;

/* This entrypoint is called to put a text message into the log */

log_write_$open:
     entry (P_log_dname, P_log_ename, P_create_sw, P_log_write_data_ptr, P_code);

	open_for_migrate = "0"b;
	goto OPEN_COMMON;



log_write_$open_for_migrate:
     entry (P_log_dname, P_log_ename, P_create_sw, P_log_write_data_ptr, P_code);

	open_for_migrate = "1"b;			/* P_log_ename, in this case, is the primary name of the */
	goto OPEN_COMMON;				/* log, NOT the name of a specific segment */



OPEN_COMMON:
	P_log_write_data_ptr = null ();

	system_area_ptr = get_system_free_area_ ();
	allocate log_write_data in (system_area) set (log_write_data_ptr);
	unspec (log_write_data) = ""b;

	log_write_data.log_ptr = null ();
	log_write_data.migrating = open_for_migrate;

	on condition (cleanup) begin;
	     call log_write_$close (log_write_data_ptr, (0));
	end;

/* For either open case, we take the dir name we received.	For the plain $open
   case, that's true of the entry name as well.  However, for the $open_for_migrate
   case, we have to find the newest in a series of already renamed logs, or, if
   there aren't any, create one with a name based on the current time.  The log_name
   itself is the entry name we were given, in either case. */

	log_write_data.dname = P_log_dname;
	log_write_data.log_name = P_log_ename;

	if log_write_data.migrating then do;
	     call log_list_history_$single_dir_oldest_and_newest /* See if we can find newest ename.YYYYMMDD.HHMMSS */
		(P_log_dname, P_log_ename, (""), log_write_data.ename, (0), code);

	     if (code = 0) then ;			/* OK: we found some oldies */

	     else if (code = error_table_$nomatch) then	/* Also OK: Nothing there now, so we create the first */
		log_write_data.ename = log_name_$name (P_log_ename, clock ()); /* Depending on P_create_sw, below */

	     else call abort_open (code);		/* Otherwise, it's an error */
	end;

	else log_write_data.ename = P_log_ename;	/* Vanilla case, use what we got */
%page;

/* What follows is the code common for both types of open operations */

	call log_initiate_ (log_write_data.dname, log_write_data.ename, 10, log_write_data.log_ptr, code);

	log_not_initialized = (code = error_table_$log_uninitialized);

/* If it exists, we consider using it. First, check to see whether it can be
   written; if not, give up immediately. Next, if it wasn't initialized,
   check to see whether it's a whole empty page, and initialize it only if
   it is-- that avoids trashing a random segment that isn't actually a log.
   Finally, if migrating, put it back in service and be gone. */

	if (code = 0) | log_not_initialized then do;	/* The named segment exists. Use it. */
GET_LOG_INFO:
	     call log_create_$get_info (addr (log_write_data.segment_info), log_write_data.log_ptr, code);
	     if (code ^= 0) then
		call abort_open (code);

	     if (log_write_data.effective_mode ^= RW_ACCESS) & (log_write_data.effective_mode ^= REW_ACCESS) then
		call abort_open (error_table_$no_w_permission);

	     if log_not_initialized then		/* Check whether anything is there */
		if (unspec (log_write_data.log_ptr -> based_page) ^= ""b) then
		     call abort_open (error_table_$log_segment_invalid);

		else do;				/* It has nothing there, so initialize it */
		     call log_initialize_ (null (), log_write_data.log_ptr,
			(log_data_$default_log_size), log_write_data.dname, code);
		     if (code ^= 0) then
			call abort_open (code);
		     else log_not_initialized = "0"b;
		end;

	     if log_write_data.migrating then		/* It's out of service now, so turn it back on */
		call log_segment_$place_in_service (log_write_data.log_ptr, (0)); /* but ignore errors */
	     else do;				/* Make sure we have a usable log since our caller apparently wants to write to it. */
		call log_segment_$get_service_bit (log_write_data.log_ptr, service_bit, code);
		if (code ^= 0) then			/* should always be possible */
		     call abort_open (code);
		if (service_bit ^= "1"b) then do;	/* need to wait for new log segment */
		     call initiate_new_log_segment$$open;
		     goto GET_LOG_INFO;		/* make sure the new one has proper access */
		end;
	     end;
	end;

/* If it didn't exist, and we were supposed to create it, take care of that */

	else if P_create_sw & (code = error_table_$noentry) then do;
	     log_write_data.rings (*) = cu_$level_get ();
	     log_write_data.access_class = get_process_access_class_ ();
	     log_write_data.max_length = log_data_$default_log_size;
	     call log_create_$new_segment (addr (log_write_data.segment_info), log_write_data.log_ptr, code);
	     if (code ^= 0) then
		call abort_open (code);
	end;

	else call abort_open (code);

	P_log_write_data_ptr = log_write_data_ptr;
	call finished (0);
%page;

log_write_$close:
     entry (P_log_write_data_ptr, P_code);

	log_write_data_ptr = P_log_write_data_ptr;
	if (log_write_data_ptr = null ()) then call finished (0);

	P_log_write_data_ptr = null ();
	system_area_ptr = get_system_free_area_ ();

	if (log_write_data.acl_count ^= 0) & (log_write_data.acl_ptr ^= null ()) then
	     free log_write_data.acl_ptr -> based_word in (system_area);

	if (log_write_data.log_ptr ^= null ()) then do;

/* If we are migrating, we take this segment out of service, and also give it
   a name more befitting its station-- a suffix accurately representing the
   newest message it contains.  This renaming, though, may result in name
   duplications, which we have no way to handle, so we just ignore the
   status code. */

	     if log_write_data.migrating then do;
		call log_segment_$remove_from_service (log_write_data.log_ptr, (0));
		call rename_for_last_message (log_write_data.log_ptr, log_write_data.ename, (0));
	     end;

	     call hcs_$terminate_noname (log_write_data.log_ptr, (0));
	     log_write_data.log_ptr = null ();
	end;

	free log_write_data in (system_area);

	call finished (0);
%page;

log_write_$message:
     entry (P_log_write_data_ptr, P_severity, P_message, P_log_message_ptr, P_code);

	log_write_data_ptr = P_log_write_data_ptr;

	unspec (message_info) = ""b;
	message_info.time = clock ();
	message_info.process_id = get_process_id_ ();
	message_info.severity = P_severity;
	message_info.text_ptr = addr (P_message);
	message_info.text_lth = length (P_message);

	call add_message ("1"b);

	P_log_message_ptr = log_message_ptr;
	call finished (0);
%page;

/* This entrypoint is called to put a message in the log including binary data */

log_write_$data:
     entry (P_log_write_data_ptr, P_severity,
	P_message, P_data_ptr, P_data_lth, P_data_class, P_log_message_ptr, P_code);

	log_write_data_ptr = P_log_write_data_ptr;

	unspec (message_info) = ""b;
	message_info.time = clock ();
	message_info.process_id = get_process_id_ ();
	message_info.severity = P_severity;
	message_info.text_ptr = addr (P_message);
	message_info.text_lth = length (P_message);
	message_info.data_ptr = P_data_ptr;
	message_info.data_lth = P_data_lth;
	message_info.data_class = P_data_class;

	call add_message ("1"b);

	P_log_message_ptr = log_message_ptr;
	call finished (0);
%page;

/* This entrypoint is called to put a message in the log with arbitrary
   contents. The caller must fill it in after this returns, and then must
   call log_segment_$finish itself to complete the job. The caller has
   the option of setting a sequence number here, as well; if this number
   is non-zero, add_message will call log_segment_$create_message_number.
*/


log_write_$general:
     entry (P_log_write_data_ptr, P_sequence, P_message_lth, P_data_lth, P_data_class, P_log_message_ptr, P_code);

	log_write_data_ptr = P_log_write_data_ptr;

	unspec (message_info) = ""b;
	message_info.sequence = P_sequence;
	message_info.text_lth = P_message_lth;		/* Set only the length-determining information */
	message_info.data_lth = P_data_lth;
	message_info.data_class = P_data_class;

	call add_message ("0"b);

	P_log_message_ptr = log_message_ptr;
	call finished (0);
%page;

add_message:
     procedure (P_finish_message);

declare  P_finish_message bit (1) aligned parameter;
declare  fault_occurred bit (1) aligned;


	fault_occurred = "0"b;
	log_segment_damaged = "0"b;

	on condition (seg_fault_error) begin;
	     if fault_occurred then do;
		code = error_table_$log_segment_damaged;
		goto MAIN_RETURN;
	     end;

	     fault_occurred = "1"b;
	     call create_new_log_segment ();
	     goto TRY_TO_CREATE_MESSAGE;
	end;


TRY_TO_CREATE_MESSAGE:
	do while (^create_message ());
	end;

	if ^P_finish_message then return;		/* Leave it to our caller to fill in and finish */

	log_message.time = message_info.time;
	log_message.severity = message_info.severity;
	log_message.process_id = message_info.process_id;

	log_message.text = message_text;
	if (message_info.data_lth > 0) then do;
	     log_message.data_class = message_info.data_class;
	     log_message.data = message_data;
	end;

	call log_segment_$finish_message (log_write_data.log_ptr, log_message_ptr, code);
	if (code ^= 0) then call finished (code);

	if log_write_data.log_ptr -> log_segment.listeners_registered then /* This test repeated here for efficiency */
	     call log_wakeup_$send_wakeups (log_write_data.log_ptr, log_message_ptr, (0));

	revert condition (seg_fault_error);

	return;
     end add_message;
%page;

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

	if (message_info.sequence > 0) then		/* Caller-supplied sequence number from log_write_$general */
	     call log_segment_$create_message_number (log_write_data.log_ptr,
		message_info.text_lth, message_info.data_lth, message_info.data_class, message_info.sequence,
		log_message_ptr, code);

	else call log_segment_$create_message (log_write_data.log_ptr,
		message_info.text_lth, message_info.data_lth, message_info.data_class,
		log_message_ptr, code);

	if (code = 0) then return ("1"b);

/* If our message won't fit, we have to swap log segments. This is done by taking the old
   one out of service and creating a new one. However, it's quite possible that someone
   else has also found the log full, and taken it out of service before we could, so we
   have to pay close attention to what happens when we take it out of service. */

	else if (code = error_table_$log_segment_full) then do;
	     on cleanup call CLEANUP;
	     call MASK;
	     call log_segment_$remove_from_service (log_write_data.log_ptr, code);

	     if (code = 0) then
		call create_new_log_segment ();
	     else call initiate_new_log_segment ();
	     call UNMASK;
	     return ("0"b);				/* Come around and try again */
	end;

	else if (code = error_table_$log_out_of_service) then do;
	     call initiate_new_log_segment ();
	     return ("0"b);
	end;

/* If it got munched for some reason, we give up on this one, and try to create a
   new one. If we encounter this error more than once, though, we just give up--
   that probably indicates some fairly serious internal logic error. For politeness,
   we *try* to take the old segment out of service, though, really, its disposition
   doesn't matter in the slightest at this point. */

	else if (code = error_table_$log_segment_damaged) then do;
	     if log_segment_damaged then
		call finished (code);
	     log_segment_damaged = "1"b;		/* Remember that this has been tried already */

	     on cleanup call CLEANUP;
	     call MASK;
	     call log_segment_$remove_from_service (log_write_data.log_ptr, (0));
	     call create_new_log_segment ();
	     call UNMASK;
	end;

	else call finished (code);			/* Any other error is fatal */

     end create_message;
%page;

initiate_new_log_segment:
     procedure ();

declare  old_log_ptr pointer;
declare  new_log_ptr pointer;
declare  retry_count fixed bin;
declare  abort_proc entry (fixed bin (35)) variable;

/* This call will try several times, returning only when new_log_ptr is different
   from old_log_ptr.  When a log fills, it is renamed (in this case, by another
   process, so it won't affect our segment number), and this procedure tries to
   initiate with the old name, eventually (it hopes) getting the new segment of
   that name. */

	abort_proc = finished;
	goto initiate_new_log_segment_join;

initiate_new_log_segment$$open:
     entry ();					/* entrypoint used when opeining a log for writing */

	abort_proc = abort_open;

initiate_new_log_segment_join:
	old_log_ptr = log_write_data.log_ptr;

	do retry_count = 1 to 10;
	     call log_initiate_ (log_write_data.dname, log_write_data.ename, 1, new_log_ptr, code);

	     if (code = 0) & (new_log_ptr ^= old_log_ptr) then do;
		call hcs_$terminate_noname (old_log_ptr, (0));
		log_write_data.log_ptr = new_log_ptr;
		return;
	     end;

	     call sleep (ONE_QUARTER_SECOND);
	end;

/* If we run out of tries at this, then the process that set the log out-of-service
   hasn't finished its job: no new log has been created, or, if it has been created,
   it has not been initialized. Our caller loses. This shouldn't happen, of course,
   since that whole task is handled by create_new_log_segment, below */

	if (code = 0) then				/* Old log still exists (presumably, out of service) */
	     call abort_proc (error_table_$log_out_of_service);
	else call abort_proc (code);

     end initiate_new_log_segment;
%page;

create_new_log_segment:
     procedure ();

/* This procedure renames the old log segment and creates a new one */

declare  new_log_ptr pointer;
declare  1 this_segment_info aligned like log_segment_info;
declare  orig_log_ptr pointer;
declare  rename_time fixed bin (71);


	this_segment_info = log_write_data.segment_info;
	orig_log_ptr = log_write_data.log_ptr;

/* When a log segment fills, it gets a suffix that's guaranteed to be
   as late or later (by adding ONE_SECOND) than the last message in the log.
   Once it's full, we rename it to an appropriate name. */

	call rename_for_last_message (orig_log_ptr, log_write_data.ename, rename_time);

	if log_write_data.migrating then		/* These calls modify this_segment_info and leave */
	     call create_migration_segment (rename_time); /* code set to indicate their success or failure */
	else call create_initial_segment ();

/* We terminate and give up on the old one, regardless-- WITHOUT modifying code */

	call hcs_$terminate_noname (orig_log_ptr, (0));
	log_write_data.log_ptr = null ();

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

	log_write_data.segment_info = this_segment_info;
	log_write_data.log_ptr = new_log_ptr;

	return;
%page;

create_initial_segment:
	procedure ();

	     call log_create_$duplicate_segment (addr (this_segment_info),
		log_write_data.dname, log_write_data.log_name, orig_log_ptr, new_log_ptr, code);

	     if (code = 0) then			/* All went well, we managed to duplicate the segment */
		return;

	     this_segment_info = log_write_data.segment_info; /* Since it may have been altered above */
	     this_segment_info.ename = log_write_data.log_name;

	     call log_create_$new_segment (addr (this_segment_info), new_log_ptr, code);

	     return;				/* code is set to indicate success/failure */
	end create_initial_segment;
%page;

create_migration_segment:
	procedure (P_start_time);

declare  P_start_time fixed bin (71) parameter;

declare  tries fixed bin;
declare  new_log_name char (32);
declare  keep_trying bit (1) aligned;


	     keep_trying = "1"b;
	     do tries = 1 to MAX_TRIES while (keep_trying);
		new_log_name = log_name_$name (log_write_data.log_name, (P_start_time + (tries * ONE_SECOND)));
		call log_create_$duplicate_segment (addr (this_segment_info),
		     log_write_data.dname, new_log_name, orig_log_ptr, new_log_ptr, code);

		if (code = 0) then			/* If it's created, our job is done. */
		     return;			/* Otherwise, as long as we keep getting name duplications, */
		if (code ^= error_table_$namedup) then	/* Keep trying different names. Any other sort of error */
		     keep_trying = "0"b;		/* is cause for giving up and going on to the new-segment */
	     end;					/* case, the assumption being that duplication failed. */

	     do tries = 1 to MAX_TRIES while (keep_trying);
		this_segment_info = log_write_data.segment_info; /* Since it may have been altered above */
		this_segment_info.ename = log_name_$name (log_write_data.log_name, (P_start_time + (tries * ONE_SECOND)));
		call log_create_$new_segment (addr (this_segment_info), new_log_ptr, code);

		if (code = 0) then			/* Error return logic is as above. */
		     return;
		if (code ^= error_table_$namedup) then
		     keep_trying = "0"b;
	     end;

	     return;
	end create_migration_segment;

     end create_new_log_segment;
%page;

rename_for_last_message:
     procedure (P_log_ptr, P_current_name, P_rename_time);

declare  P_log_ptr pointer parameter;
declare  P_current_name char (32) parameter;
declare  P_rename_time fixed bin (71) parameter;

declare  name_time fixed bin (71);
declare  new_name char (32);
declare  tries fixed bin;

	name_time = P_log_ptr -> log_segment.last_time;

/* The idea here is to keep trying later names until it can be set to
   some name that is later than the last message in the segment. */

	do tries = 1 to MAX_TRIES;			/* Don't try too many times.... */
	     name_time = name_time + ONE_SECOND;	/* Add a delta so the suffix is guaranteed to be later */

	     new_name = log_name_$name (log_write_data.log_name, name_time);

	     call hcs_$chname_seg (P_log_ptr, P_current_name, new_name, code);

	     if (code = error_table_$segnamedup) then	/* If it's already this, we're restarting after an */
		code = 0;				/* error, and the code can be ignored. */

	     if (code = 0) then do;			/* It worked */
		P_current_name = new_name;		/* Set it back for our caller */
		P_rename_time = name_time;		/* Say what time the old one has */
		return;
	     end;

	     else if (code ^= error_table_$namedup) then	/* Nope, couldn't do it at all */
		call finished (code);

	     if ((name_time + ONE_SECOND) > clock ()) then/* Come around for another try, */
		call sleep (ONE_SECOND);
	end;					/* but don't let it get ahea of the clock */

	call sub_err_ (0, WHOAMI, ACTION_CANT_RESTART, null (), "",
	     "Tried (unsuccessfully) more than ^d times to rename log segment ^a (^p)",
	     (tries - 1), P_current_name, P_log_ptr);

     end rename_for_last_message;
%page;

sleep: procedure (interval);

/* Internal procedure to pause for a specified interval.  It is
   used when we need to wait for some other process to finish some
   manipulation of the log segments. We perform our own mask
   setting here if our caller is not already masked. */

dcl  interval fixed bin (71) parameter;			/* sleep time in microseconds */

	if substr(mask, 36, 1) = "0"b
	then do;
	     on cleanup call CLEANUP;
	     call MASK;
	     call timer_manager_$sleep (interval, RELATIVE_MICROSECONDS);
	     call UNMASK;
	end;
	else call timer_manager_$sleep (interval, RELATIVE_MICROSECONDS);

     end sleep;


/* format: off */

%page; %include log_message;
%page; %include log_segment;
%page; %include log_write_data;
%page; %include sub_err_flags;
%page; %include access_mode_values;

	end log_write_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
