convert_syserr_log.pl1          03/14/85  0834.9r w 03/13/85  1100.0      132237



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

/* *	CONVERT_SYSERR_LOG
   *
   *	This proces converts the existing syserr log vfile into a new-format
   *	family of log segments.  It converts binary messages by making the
   *	appropriate data_class entries.
   *
   *	Modification history:
   *	84-06-08, W. Olin Sibert: Derived from display_cpu_error, nee mos_edac_summary
   *	84-12-14, WOS: Changed to ignore expected (no admin_gate_) open err
   *	84-12-21, WOS: Changed to declare data_class char (16) varying.
   *	85-01-21, EJ Sharpe: convert bin data class to char data class
   */

dcl  arg char (arg_len) based (arg_ptr);		/* A command argument */
dcl  arg_count fixed bin;				/* The number of arguments */
dcl  arg_len fixed bin;				/* Length of an argument */
dcl  arg_list_ptr ptr;				/* Pointer to commands argument list */
dcl  arg_no fixed bin init (1);			/* For scanning argument list */
dcl  arg_ptr ptr;					/* Pointer to an argument */

dcl  code fixed bin (35);				/* Standard system status code */
dcl  count_limit fixed bin init (0);			/* Results for -limit arg */

dcl  day_limit fixed bin init (0);			/* Results for -day_limit arg */
dcl  err_cnt fixed bin init (0);			/* Entries in status table */
dcl  expand_sw bit (1) init ("0"b);			/* Set if user just wants hregs interpreted */

dcl  for_arg char (for_len) based (for_ptr);		/* This is the -for argument */
dcl  for_len fixed bin;				/* Saved length of -for argument */
dcl  for_ptr ptr;					/* Saved pointer to the -for argument */
dcl  for_sw bit (1) init ("0"b);			/* Set if -for used */
dcl  for_time fixed bin (71);				/* Time specified on -for */
dcl  from_sw bit (1) init ("0"b);			/* Set if -from used */
dcl  from_time fixed bin (71);			/* Time specified on -from */

dcl  more_args bit (1);				/* Set while there are more arguments to scan */
dcl  msg_seq fixed bin (35);				/* Sequence number */
dcl  msg_time fixed bin (71);				/* Time of syserr message */

dcl  open_status bit (36) aligned;			/* Code from old_syserr_log_util_$open */
dcl  read_count fixed bin;
declare	binary_count fixed bin;

dcl  (tm1, tm2) char (24);				/* Used to call date_time_ */
dcl  to_sw bit (1) init ("0"b);			/* Set if -to used */
dcl  to_time fixed bin (71);				/* Time specified on -to */

dcl  new_log_dir char (168);
dcl  log_write_data_ptr pointer;

dcl  workp ptr;					/* Pointer to work segment */
dcl  1 work aligned based (workp),			/* Declaration of work segment */
       2 cpureq (8) char (1),				/* Table of requested CPUs */
       2 buffer (500) bit (36) aligned;			/* Syserr messages are read here */

/* Constants */

dcl  WHOAMI char (32) int static options (constant) init ("convert_syserr_log");
						/* Name of procedure */

dcl  error_table_$badopt fixed bin (35) external static;
dcl  error_table_$end_of_info fixed bin (35) external static;
dcl  error_table_$inconsistent fixed bin (35) external static;
dcl  error_table_$moderr fixed bin (35) external static;
dcl  error_table_$noarg fixed bin (35) external static;
dcl  error_table_$too_many_args fixed bin (35) external static;

dcl  log_data_$syserr_log_dir char (168) external static;
dcl  log_data_$syserr_log_name char (32) external static;

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  log_write_$open_for_migrate entry (char (*), char (*), bit (1) aligned, pointer, fixed bin (35));
dcl  log_write_$close entry (pointer, fixed bin (35));
dcl  log_write_$general entry (pointer, fixed bin (35), fixed bin, fixed bin, char (16) varying, pointer, fixed bin (35));
dcl  log_segment_$finish_message entry (pointer, pointer, fixed bin (35));
dcl  print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  old_syserr_log_util_$open entry (bit (36) aligned, fixed bin (35));
dcl  old_syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  old_syserr_log_util_$close entry (fixed bin (35));
dcl  old_syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35));

dcl   cleanup condition;

declare  (addr, binary, bit, char, hbound, mod, null, pointer, substr, unspec) builtin;

%page;
/* Initialization */

	log_write_data_ptr = null ();
	workp = null ();

	on condition (cleanup)
	     call clean_up ();

	call get_temp_segment_ (WHOAMI, workp, code);	/* Get a work segment */
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "Can't get temp segment");
	     goto MAIN_RETURN;
	     end;

	call cu_$arg_list_ptr (arg_list_ptr);		/* Need pointer to argument list */
	call cu_$arg_count (arg_count);		/* And the length */
	more_args = (arg_count > 0);			/* Set if args to scan */
	call scan_args;				/* Scan the argument list */

	call old_syserr_log_util_$open (open_status, code);	/* Open the syserr log */
	if (code = error_table_$moderr) & (substr (open_status, 1, 2) = "01"b) then ;
						/* Ignore the "expected" error */

	else if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do;
						/* If error */
	     call print_syserr_msg_$open_err (open_status, WHOAMI, code);
	     if code ^= 0 then goto MAIN_RETURN;		/* Not recoverable */
	     end;

	if ^from_sw then do;			/* No -from, so start at beginning */
	     call old_syserr_log_util_$search (0, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, WHOAMI, "Can't find first message in log.");
		goto MAIN_RETURN;
		end;
	     from_time = msg_time;			/* Official starting time */
	     end;
	else do;					/* -from used, find right message */
	     call old_syserr_log_util_$search (from_time, msg_time, msg_seq, code);
	     if code ^= 0 then do;
		call com_err_ (code, WHOAMI, "Locating first message requested.");
		goto MAIN_RETURN;
		end;
	     end;

	if for_sw then do;				/* Now can compute -for limit */
	     call convert_date_to_binary_$relative (for_arg, to_time, from_time, code);
	     if code ^= 0 then do;
		call com_err_ (code, WHOAMI, "-for ^a", for_arg);
		goto MAIN_RETURN;
		end;
	     to_sw = "1"b;				/* Now, just as if -to was specified */
	     end;
	if ^to_sw then to_time = from_time;		/* Initialize last message time */

	syserr_msgp = addr (work.buffer);		/* Read here */
%page;

	call print_header;

	call log_write_$open_for_migrate
	    (new_log_dir, log_data_$syserr_log_name, "1"b, log_write_data_ptr, code);
	if (code ^= 0) then do;
	     call com_err_ (code, WHOAMI, "Opening new log directory ^a", new_log_dir);
	     goto MAIN_RETURN;
	     end;

/* Loop thru the file */

	binary_count = 0;
	do read_count = 0 by 1;
	     call old_syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code);
	     if code ^= 0 then do;
		if (code ^= error_table_$end_of_info) then
		     call com_err_ (code, WHOAMI, "Reading syserr log");
		goto FINISHED_SCAN;
		end;

	     if to_sw then do;			/* If time limit */
		if syserr_msg.time > to_time then goto FINISHED_SCAN;
		end;
	     else to_time = syserr_msg.time;		/* Save last message time */

	     call process_message ();

	     if (read_count ^= 0) & (mod (read_count, 1000) = 0) then
		call ioa_ ("^a: Processed ^dth message.", WHOAMI, read_count);
	     end;


FINISHED_SCAN:
	call ioa_ ("^a: Processed ^d message^[s^] (^d binary)",
	     WHOAMI, read_count, (read_count ^= 1), binary_count);

MAIN_RETURN:
	call clean_up ();
	return;
%page;
/* Procedure to copy a single message */

process_message:
     procedure ();

declare	data_class char (16) varying;
declare	data_lth fixed bin;
declare	data_idx fixed bin;
declare   data_buffer (data_lth) bit (36) aligned based;


	if (syserr_msg.data_size > 0) then do;
	     call convert_data_class ((syserr_msg.data_code), data_class);
	     data_lth = syserr_msg.data_size;
	     end;
	else do;
	     data_class = "";
	     data_lth = 0;
	     end;

	call log_write_$general (log_write_data_ptr,
	     syserr_msg.seq_num, (syserr_msg.text_len), data_lth, data_class, log_message_ptr, code);
	if (code ^= 0) then do;
	     call com_err_ (code, WHOAMI, "Cannot allocate copy of message ^d", syserr_msg.seq_num);
	     goto FINISHED_SCAN;
	     end;

	log_message.time = syserr_msg.time;
	log_message.severity = syserr_msg.code;
	log_message.process_id = ""b;		/* We have no idea */
	log_message.text = syserr_msg.text;

/* In this version, the binary data is a word of type, followed by the original binary data */

	if (data_lth > 0) then do;			/* Copy binary data only if there is some */
	     unspec (addr (log_message.data(1)) -> data_buffer) = unspec ( addr (syserr_msg.data(1)) -> data_buffer);
	     binary_count = binary_count + 1;
	     end;

	call log_segment_$finish_message (pointer (log_message_ptr, 0), log_message_ptr, code);
	if (code ^= 0) then do;
	     call com_err_ (code, WHOAMI, "Cannot finish message ^d at ^p", syserr_msg.seq_num, log_message_ptr);
	     goto FINISHED_SCAN;
	     end;

	return;

convert_data_class:
     procedure (a_syserr_bin_class, a_syserr_char_class);

declare   a_syserr_bin_class fixed bin parameter;
declare   a_syserr_char_class char (16) varying parameter;
declare   syserr_bin_class fixed bin;
declare   syserr_char_class char (16) varying;
declare   hbound builtin;
declare   ioa_$rsnnl entry () options (variable);

	syserr_bin_class = a_syserr_bin_class;
	syserr_char_class = "";
	if syserr_bin_class < 1  |  syserr_bin_class > hbound(SB_char_data_classes, 1)
	then call ioa_$rsnnl ("syserr^d", syserr_char_class, (0), syserr_bin_class);
	else syserr_char_class = SB_char_data_classes (syserr_bin_class);

	a_syserr_char_class = syserr_char_class;
	end convert_data_class;

	end process_message;
%page;
/* Procedure to scan the argument list */

scan_args:
     proc;

	new_log_dir = "";

	do while (more_args);			/* Do while thins to look at */
	     call get_arg;
	     if arg = "-from" | arg = "-fm" then do;	/* Start time */
		from_sw = "1"b;
		call time_arg (from_time);
		end;
	     else if arg = "-to" then do;		/* Ending time */
		to_sw = "1"b;
		call time_arg (to_time);
		end;
	     else if arg = "-for" then do;		/* Time limit */
		for_sw = "1"b;
		call time_arg (for_time);		/* For syntax checking only */
		for_len = arg_len;			/* Save pointer to this argument */
		for_ptr = arg_ptr;
		end;

	     else if (arg = "-default") | (arg = "-dft") then do;
		if (new_log_dir ^= "") then do;
		     call com_err_ (error_table_$too_many_args,
			WHOAMI, "Only one log directory may be specified. ^a", arg);
		     goto MAIN_RETURN;
		     end;

		new_log_dir = log_data_$syserr_log_dir;
		end;

	     else if (char (arg, 1) = "-") then do;	/* Bad control argument */
		call com_err_ (error_table_$badopt, WHOAMI, "^a", arg);
		goto MAIN_RETURN;
		end;

	     else if (new_log_dir ^= "") then do;
		call com_err_ (error_table_$too_many_args, WHOAMI, "Only one log directory may be specified. ^a", arg);
		goto MAIN_RETURN;
		end;

	     else do;
		call absolute_pathname_ (arg, new_log_dir, code);
		if (code ^= 0) then do;
		     call com_err_ (code, WHOAMI, "Log directory ^a", arg);
		     goto MAIN_RETURN;
		     end;
		end;
	     end;


	if to_sw & for_sw then do;			/* Conflict */
	     call com_err_ (error_table_$inconsistent, WHOAMI, "Conflicting arguments: -to and -for");
	     goto MAIN_RETURN;
	     end;

	if (new_log_dir = "") then do;
	     call com_err_ (error_table_$noarg, WHOAMI, "Usage:  ^a	 NewLogDirectory {-control_args}", WHOAMI);
	     goto MAIN_RETURN;
	     end;

	return;

     end scan_args;
%page;
/* Procedure to return the next argument from command line */

get_arg:
     proc;

	call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr);
	if code ^= 0 then do;			/* Should never happen */
	     call com_err_ (code, WHOAMI, "Arg ^d", arg_no);
	     goto MAIN_RETURN;
	     end;
	arg_no = arg_no + 1;			/* For next call */
	more_args = (arg_no <= arg_count);
	return;

put_arg:
     entry;					/* Entry to return argument after scanning too far */
	arg_no = arg_no - 1;
	more_args = (arg_no <= arg_count);
	return;

     end get_arg;

/* Procedure to convert a time argument */

time_arg:
     proc (t);

dcl  arg_copy char (10) var;				/* Save copy of arg here */
dcl  t fixed bin (71);				/* The time to ouput */


	arg_copy = arg;
	if ^more_args then do;			/* Must be more */
	     call com_err_ (0, WHOAMI, "Argument required after ^a.", arg_copy);
	     goto MAIN_RETURN;
	     end;
	call get_arg;
	call convert_date_to_binary_ (arg, t, code);
	if code ^= 0 then do;
	     call com_err_ (code, WHOAMI, "^a ^a", arg_copy, arg);
	     goto MAIN_RETURN;
	     end;

	return;

     end time_arg;
%page;

/* Procedure to print the header line */

print_header:
     proc;


	call date_time_ (from_time, tm1);		/* Starting time is easy */

	if to_sw
	then call date_time_ (to_time, tm2);		/* Stop time is easy if given */
	else do;					/* Otherwise get last message	 */
	     call old_syserr_log_util_$search (-1, msg_time, msg_seq, code);
						/* Search to eof */
	     if code ^= 0 then do;			/* Should not fail */
log_err:
		call com_err_ (code, WHOAMI, "From old_syserr_log_util_$search.");
		return;
		end;

	     call date_time_ (msg_time, tm2);		/* Edit time */
	     call old_syserr_log_util_$search (from_time, msg_time, msg_seq, code);
						/* Back to first msg */
	     if code ^= 0 then goto log_err;
	     end;

	call ioa_ ("^/Converting syserr log into ^a,^/^3xfrom ^a to ^a", new_log_dir, tm1, tm2);

	return;

     end print_header;


%page;
/* Cleanup handler */

clean_up:
     proc;

	call old_syserr_log_util_$close ((0));

	if (workp ^= null ()) then
	     call release_temp_segment_ (WHOAMI, workp, (0));

	if (log_write_data_ptr ^= null ()) then
	     call log_write_$close (log_write_data_ptr, (0));

	return;
	end clean_up;

%page; %include syserr_message;
%page; %include syserr_binary_def;
%page; %include log_message;

	end convert_syserr_log;




		    display_log_segment.pl1         01/17/85  0841.8r w 01/17/85  0834.5       66663



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
display_log_segment:
dls:
     procedure () options (variable);

/* *	DISPLAY_LOG_SEGMENT
   *
   *	This is a tool for the new log primitives. It is used to display the
   *	contents of a single log segment, in unformatted form.
   *
   *	84-06-01, W. Olin Sibert
   */

declare	arg_count fixed bin;
declare	arg_lth fixed bin (21);
declare	arg_ptr pointer;
declare	arg char (arg_lth) based (arg_ptr);
declare	arg_idx fixed bin;
declare	code fixed bin (35);

declare	brief_sw bit (1) aligned;
declare	trace_sw bit (1) aligned;
declare	header_sw bit (1) aligned;
declare	print_sw bit (1) aligned;

declare   log_data_$new_message_flag bit (36) aligned external static;
declare   log_data_$complete_message_flag bit (36) aligned external static;

declare	error_table_$badopt fixed bin (35) external static;
declare	error_table_$noarg fixed bin (35) external static;
declare	error_table_$inconsistent fixed bin (35) external static;
declare	error_table_$null_info_ptr fixed bin (35) external static;
declare	error_table_$too_many_args fixed bin (35) external static;

declare	com_err_ entry options (variable);
declare	cu_$arg_count entry (fixed bin, fixed bin (35));
declare	cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
declare	cv_ptr_ entry (char (*), fixed bin (35)) returns (pointer);
declare	cv_ptr_$terminate entry (pointer);
declare	ioa_ entry options (variable);
declare	log_format_time_ entry (fixed bin (71)) returns (char (32) varying);

declare	WHOAMI char (32) internal static options (constant) init ("display_log_segment");

declare	cleanup condition;

declare  (addr, addrel, binary, char, currentsize, null, substr, unspec) builtin;

/* */

	log_segment_ptr = null ();

	on condition (cleanup) call clean_up ();

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

	call process_args ();

	if header_sw then call display_log ();

	if print_sw then
	     call display_messages ("1"b);
	else if trace_sw then
	     call display_messages ("0"b);

MAIN_RETURN:
	call clean_up ();
	return;

/* */

display_log:
     procedure ();

	call ioa_ ("");
	call ioa_ ("Log segment version ""^a"" at ^p:", log_segment.version, log_segment_ptr);
	call ioa_ ("^3xCreated at ^a", log_format_time_ (log_segment.time_created));
	call ioa_ ("^3x^[No previous log^;Previous log in:^4x""^a""^]",
	     (log_segment.previous_log_dir = ""), log_segment.previous_log_dir);
	call ioa_ ("^3xFirst/last messages: ^d / ^d", log_segment.first_sequence, log_segment.last_sequence);
	call ioa_ ("^3xFirst/last time:     ^a / ^a",
	     log_format_time_ (log_segment.first_time), log_format_time_ (log_segment.last_time));
	call ioa_ ("^3xLast word used:       ^6oo   (^[in^;out of^] service)",
	     binary (substr (unspec (log_segment.alloc_info), 55, 18)),
	     substr (unspec (log_segment.alloc_info), 54, 1));
	call ioa_ ("^3xReal last sequence:  ^d", binary (substr (unspec (log_segment.alloc_info), 18, 36)));
	call ioa_ ("^3xLast word available:  ^6oo", log_segment.max_size);
	call ioa_ ("^3xFirst message at:    ^p", addr (log_segment.data));
	call ioa_ ("^3xListener info not printed yet.");
	call ioa_ ("");

	return;
	end display_log;

/* */

display_messages:
    procedure (P_text);

declare	P_text bit (1) aligned parameter;

declare	msg_idx fixed bin (18);
declare	wasted_space fixed bin;
declare	last_message fixed bin (18);
declare	msg_type char (32);


	msg_idx = 1;
	last_message = binary (substr (log_segment.alloc_info.word_2, 19, 18));
	wasted_space = 0;

	do while (msg_idx <= last_message);
	     log_message_ptr = addr (log_segment.data (msg_idx));
               if (log_message.sentinel = log_data_$new_message_flag) then
		msg_type = "Incomplete message";
               else if (log_message.sentinel = log_data_$complete_message_flag) then
		msg_type = "Complete message";
	     else do;
		wasted_space = wasted_space + 1;
		msg_idx = msg_idx + 1;
		goto NEXT_WORD;
		end;

	     if (wasted_space > 0) then
		call ioa_ ("Wasted space^7xat ^p (^d words)",
		     addrel (log_message_ptr, (0 - wasted_space)), wasted_space);
	     wasted_space = 0;

	     call ioa_ ("^18a at ^p: ^d chars, ^d words",
		msg_type, log_message_ptr, log_message.text_lth, log_message.data_lth);

	     if P_text then do;
		call ioa_ ("^3xSequence:^5x^d", log_message.sequence);
		call ioa_ ("^3xSeverity:^5x^d", log_message.severity);
		call ioa_ ("^3xTime:^9x^a", log_format_time_ ((log_message.time)));
		call ioa_ ("^3xProcess:^6x^w", log_message.process_id);
		call ioa_ ("^3xText:^9x""^a""", log_message.text);

		if (log_message.data_lth ^= 0) then do;
		     call ioa_ ("^3xData class:^3x""^a""", log_message.data_class);
		     call ioa_ ("^3xData:^9x^d words at ^p", log_message.data_lth, addr (log_message.data));
		     end;
		call ioa_ ("");

		end;

	     msg_idx = msg_idx + currentsize (log_message);

NEXT_WORD:
	     end;

	if (wasted_space > 0) then
	     call ioa_ ("Wasted space^7xat ^p (^d words)^/",
		addrel (log_message_ptr, (0 - wasted_space)), wasted_space);

	return;
	end display_messages;

/* */

process_args:
     procedure ();

	brief_sw = "0"b;
	header_sw = "1"b;
	trace_sw = "0"b;
	print_sw = "0"b;

	do arg_idx = 1 to arg_count;
	     call cu_$arg_ptr (arg_idx, arg_ptr, arg_lth, (0));

	     if (arg = "-brief") | (arg = "-bf") then brief_sw = "1"b;
	     else if (arg = "-long") | (arg = "-lg") then brief_sw = "0"b;
	     else if (arg = "-header") | (arg = "-he") then header_sw = "1"b;
	     else if (arg = "-no_header") | (arg = "-nhe") then header_sw = "0"b;
	     else if (arg = "-trace") then trace_sw = "1"b;
	     else if (arg = "-no_trace") then trace_sw = "0"b;
	     else if (arg = "-print") | (arg = "-pr") then print_sw = "1"b;
	     else if (arg = "-no_print") | (arg = "-npr") then print_sw = "0"b;

	     else if (char (arg, 1) = "-") then do;
		call com_err_ (error_table_$badopt, WHOAMI, "^a", arg);
		goto MAIN_RETURN;
		end;

	     else if (log_segment_ptr = null ()) then do;
		log_segment_ptr = cv_ptr_ (arg, code);
		if (code = 0) & (log_segment_ptr = null ()) then code = error_table_$null_info_ptr;
		if (code ^= 0) then do;
		     call com_err_ (code, WHOAMI, "^a", arg);
		     goto MAIN_RETURN;
		     end;
		end;

	     else do;
		call com_err_ (error_table_$too_many_args, WHOAMI, "Only one log pointer allowed. ^a", arg);
		goto MAIN_RETURN;
		end;
	     end;

	if (log_segment_ptr = null ()) then do;
	     call com_err_ (error_table_$noarg, WHOAMI, "^/Usage:  ^a  LOG_PTR  {-control_args}", WHOAMI);
	     goto MAIN_RETURN;
	     end;

	if (^header_sw) & (^trace_sw) & (^print_sw) then do;
	     call com_err_ (error_table_$inconsistent, WHOAMI,
		"At least one of -header, -trace, and -print must be supplied.");
	     goto MAIN_RETURN;
	     end;

	return;
	end process_args;

/* */

clean_up:
     procedure ();

	if (log_segment_ptr ^= null ()) then
	     call cv_ptr_$terminate (log_segment_ptr);

	return;
	end clean_up;

%page; %include log_segment;
%page; %include log_message;

	end display_log_segment;




		    expand_access_audit_msg_.pl1    05/13/85  1537.7rew 05/13/85  1536.0      172818



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

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

expand_access_audit_msg_:
     procedure ();

/* *      EXPAND_ACCESS_AUDIT_MSG_
   *
   *      Expander for log messages from access_audit_.
   *
   *	85-03-04, EJ Sharpe: remove some unpopular spaces from format
   *	85-01-28, EJ Sharpe: for session_uid, expander entry cache
   *	85-01-22, EJ Sharpe: for new version structures, reformat
   *      85-01-14, EJ Sharpe: changes per code audit
   *      85-01-13, EJ Sharpe: misc fixes
   *      84-12-21, EJ Sharpe: completed first revision
   *      84-12-05, W. Olin Sibert: Initial coding, on advice from Mr. Sharpe.
*/

/*	PARAMETERS	*/

declare P_log_message_format_ptr
			 pointer parameter;
declare P_log_message_ptr	 pointer parameter;
declare P_expand_mode_ptr	 pointer parameter;
declare P_expansion		 char (*) varying parameter;
declare P_code		 fixed bin (35) parameter;


/*	AUTOMATIC		*/

declare info_ptr		 pointer;
declare info_size		 fixed bin;
declare info_type		 fixed bin (9) uns;
declare save_info_size	 fixed bin;

declare audit_record_size	 fixed bin;
declare char8		 char (8) based;
declare fb9unsunal		 fixed bin (9) uns unal based;
declare temp		 char (1000) varying;
declare parent		 char (528);
declare n_subjects		 fixed bin;
declare subject_idx		 fixed bin;
declare expander_proc	 variable entry (pointer, pointer, pointer, fixed bin, char (*) varying, fixed bin (35));
declare entry_name		 char (33);
declare 1 oper_code		 aligned like encoded_access_op;
declare code		 fixed bin (35);
declare object_type_name	 char (32);
declare operation_type_name	 char (32);


/*	INTERNAL STATIC		*/

/* The next two declarations define the expander procedure associative menory
   used so we don't have to call hcs_$make_entry too often within a single session.
   Note that they're dimensioned to 36.  Should the different types of extended
   binary data exceed this number, the dimension should be increased. */

declare expanders_known	 bit (36) int static init (""b);
declare expander_am		 (36) variable int static
			 entry (pointer, pointer, pointer, fixed bin, char (*) varying, fixed bin (35));


/*	ENTRIES		*/

declare expand_log_message_$append_octal
			 entry (pointer, pointer, fixed bin, char (*) varying);
declare ioa_$rsnnl		 entry options (variable);
declare vpn_cv_uid_path_	 entry (pointer, char (*), fixed bin (35));
declare date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
declare cv_fstime_		 entry (bit (36) aligned) returns (fixed bin (71));
declare display_access_class_	 entry (bit (72) aligned) returns (char (32) aligned);
declare hcs_$make_entry	 entry (ptr, char (*), char (*), entry, fixed bin (35));


/*	MISC		*/

declare (addr, addrel, dimension, hbound, lbound, length, null, rtrim, size, substr, unspec)
			 builtin;
%page;

expand_access_audit_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	audit_record_ptr = addr (log_message.data (1));
	audit_record_size = dimension (log_message.data, 1);

	goto ACCESS_AUDIT_COMMON;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_access_audit_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	audit_record_ptr = addr (log_message.data (2));
	audit_record_size = dimension (log_message.data, 1) - 1;

	goto ACCESS_AUDIT_COMMON;
%page;

ACCESS_AUDIT_COMMON:

	info_ptr = audit_record_ptr;
	info_size = audit_record_size;
	if audit_record_header_proxy.version = ACCESS_AUDIT_HEADER_VERSION_3
						/* new version */
	then n_subjects = audit_record_header_proxy.type;
	else if audit_record_header_proxy.version = 1 | audit_record_header_proxy.version = 2
						/* old versions */
	then n_subjects = audit_record_header_proxy.version;
	else goto unknown_data;

/* make sure we have a whole header */
	if n_subjects = 1 & info_size < size (audit_record_header)
	then goto unknown_data;
	else if n_subjects = 2 & info_size < size (audit_record_header_proxy)
	then goto unknown_data;

	unspec (oper_code) = audit_record_header_proxy.operation_code;
	if oper_code.object_type = 0
	then object_type_name = "No Object";
	else if oper_code.object_type > hbound (Long_Object_Names, 1)
	then object_type_name = "UNKNOWN OBJECT";	/* new one we don't know abaout */
	else object_type_name = Long_Object_Names (oper_code.object_type);

	if oper_code.access_type = 0
	then operation_type_name = "none";
	else operation_type_name = Long_Level_Names (oper_code.access_type);

	if audit_record_header_proxy.version ^= ACCESS_AUDIT_HEADER_VERSION_3
	then do;
	     call ioa_$rsnnl ("(Old format binary)^/", temp, (0));
	     P_expansion = P_expansion || temp;
	end;

	do subject_idx = 1 to n_subjects;
	     call ioa_$rsnnl (
		"^[Proxy^;Subject^]: ^a.^a.^a^[*^] (ring ^d),^[ PID=^w,^;^s^]^[ Session_UID=^d,^;^s^]^/Auth: ^a, Min: ^a, Max: ^a^/"
		,
		temp, (0),
		((subject_idx = 1) & (n_subjects ^= 1)),
		audit_record_header_proxy.subjects (subject_idx).person,
		audit_record_header_proxy.subjects (subject_idx).project,
		audit_record_header_proxy.subjects (subject_idx).tag,
		audit_record_header_proxy.subjects (subject_idx).anonymous,
		audit_record_header_proxy.subjects (subject_idx).ring,
		(audit_record_header_proxy.subjects (subject_idx).process_id ^= ""b),
		audit_record_header_proxy.subjects (subject_idx).process_id,
		((subject_idx = 1) & (audit_record_header_proxy.session_uid ^= 0)),
		audit_record_header_proxy.session_uid,	/* only AS audit has this at present */
		display_access_class_ (audit_record_header_proxy.subjects (subject_idx).authorization),
		display_access_class_ (audit_record_header_proxy.subjects (subject_idx).authorization_range (1)),
		display_access_class_ (audit_record_header_proxy.subjects (subject_idx).authorization_range (2)));

	     P_expansion = P_expansion || temp;
	end;


	call ioa_$rsnnl (
	     "^a, operation type: ^a^[, operation detail: ^oo^;^s^]^/", temp, (0),
	     object_type_name, operation_type_name, (oper_code.detailed_operation ^= 0), oper_code.detailed_operation);
	P_expansion = P_expansion || temp;

/**** Prepare to deal with extended binary info.

      Some internal or external routine will be called to expand
      the extended binary if it exists.

      (1) The called routine (expander) must check that the info
      passed is larger or equal to the size of the structure it
      uses for expansion.

      (2) The expander must decrease the info_size argument by the
      number of words processed in that routine.  We will loop here
      calling expanders until the info is all processed.

      (3) The expander should end the expanded data with a new line
      to avoid confusion with the set of expanded data.
****/

	if n_subjects = 1
	then do;
	     info_size = info_size - size (audit_record_header);
	     info_ptr = addrel (info_ptr, size (audit_record_header));
	end;
	else do;
	     info_size = info_size - size (audit_record_header_proxy);
	     info_ptr = addrel (info_ptr, size (audit_record_header_proxy));
	end;

	do while (info_size > 0);

	     entry_name = "";			/* init expander entry name */

	     if audit_record_header_proxy.version = ACCESS_AUDIT_HEADER_VERSION_3
	     then do;				/* new version */
		info_type = info_ptr -> fb9unsunal;	/* pick off type */
		if info_type > hbound (audit_binary_expanders, 1) | info_type < lbound (audit_binary_expanders, 1)
		then goto unknown_data;

/* the first two data types we have internal procs for expansion */
		else if info_type = AAB_ss_object
		then call expand_ssobj (info_ptr, info_size);
		else if info_type = AAB_ss_link
		then call expand_link (info_ptr, info_size);

		else do;
		     entry_name = "expand_" || audit_binary_expanders (info_type) || "_audit_info_";
		     if length (rtrim (entry_name)) > 32
		     then goto no_expander;

		     if ^expander_cache$get ((info_type), expander_proc)
		     then do;
			call hcs_$make_entry (null (), entry_name, entry_name, expander_proc, code);
			if code ^= 0
			then goto no_expander;
			else call expander_cache$put ((info_type), expander_proc);
		     end;

		     save_info_size = info_size;
		     call expander_proc (P_log_message_format_ptr, P_expand_mode_ptr,
			info_ptr, info_size, P_expansion, code);
		     if code ^= 0			/* encountered problem?? */
			| save_info_size = info_size	/* did'nt adjust data size?? */
		     then do;
no_expander:
unknown_data:
			call ioa_$rsnnl ("Unknown data (^d words):^/", temp, (0), info_size);
			P_expansion = P_expansion || temp;
			call expand_log_message_$append_octal
			     (P_log_message_format_ptr, info_ptr, info_size, P_expansion);
			info_size = 0;		/* we got it all */
		     end;
		end;
	     end;
	     else do;				/* old version binary data */
		if info_size < 2
		then goto old_unknown_data;		/* need at least 8 chars to identify the type of the data */

/* the first two data types we have internal procs for expansion */
		if (info_ptr -> char8 = "ssobj_v1")
		then call expand_old_ssobj (info_ptr, info_size);
		else if (info_ptr -> char8 = "sslnk_v1")
		then call expand_old_link (info_ptr, info_size);
		else do;
		     entry_name = "expand_" || rtrim (info_ptr -> char8) || "_audit_info_";
		     if length (rtrim (entry_name)) > 32
		     then goto no_old_expander;

/* we don't maintain a cache of these... */
		     call hcs_$make_entry (null (), entry_name, entry_name, expander_proc, code);
		     if code ^= 0
		     then goto no_old_expander;

		     save_info_size = info_size;
		     call expander_proc (P_log_message_format_ptr, P_expand_mode_ptr,
			info_ptr, info_size, P_expansion, code);
		     if code ^= 0			/* encountered problem?? */
			| save_info_size = info_size	/* did'nt adjust data size?? */
		     then do;
no_old_expander:
old_unknown_data:
			call ioa_$rsnnl ("Unknown data (^d words):^/", temp, (0), info_size);
			P_expansion = P_expansion || temp;
			call expand_log_message_$append_octal
			     (P_log_message_format_ptr, info_ptr, info_size, P_expansion);
			info_size = 0;		/* we got it all */
		     end;
		end;
	     end;

	end;					/* do while loop */

	return;
%page;

expand_ssobj:
     procedure (a_info_ptr, a_info_size);

dcl     a_info_ptr		 ptr parameter;
dcl     a_info_size		 fixed bin parameter;

	audit_ssobj_info_ptr = a_info_ptr;
	if info_size < size (audit_ssobj_info)
	then goto unknown_data;

	call vpn_cv_uid_path_ (addr (audit_ssobj_info.parent_uid_path), parent, (0));

	call ioa_$rsnnl ("Object: branch ^w in ^a, DTEM is ^a^/", temp, (0),
	     audit_ssobj_info.entry_uid, parent,
	     date_time_$format ("date_time", cv_fstime_ (audit_ssobj_info.dtem), "", ""));
	P_expansion = P_expansion || temp;

	call ioa_$rsnnl ("Raw mode: ^[null^s^s^s^;^[r^]^[e^]^[w^]^]  Ring brackets: ^d,^d,^d  Class: ^a.",
	     temp, (0), (substr (audit_ssobj_info.raw_mode, 1, 3) = "000"b),
	     substr (audit_ssobj_info.raw_mode, 1, 1), substr (audit_ssobj_info.raw_mode, 2, 1),
	     substr (audit_ssobj_info.raw_mode, 3, 1), audit_ssobj_info.ring_brackets,
	     display_access_class_ (audit_ssobj_info.access_class));
	P_expansion = P_expansion || temp;

	if substr (audit_ssobj_info.ex_mode, 1, 3) ^= "000"b
	     | audit_ssobj_info.ex_ring_brackets (1) ^= "000"b
	     | audit_ssobj_info.ex_ring_brackets (2) ^= "000"b
	     | audit_ssobj_info.ex_ring_brackets (3) ^= "000"b
	then call ioa_$rsnnl (" (Ex mode: ^[null^s^s^s^;^[r^]^[e^]^[w^]^]  Ex Ring brackets: ^d,^d,^d).^/", temp, (0),
		(substr (audit_ssobj_info.ex_mode, 1, 3) = "000"b), substr (audit_ssobj_info.ex_mode, 1, 1),
		substr (audit_ssobj_info.ex_mode, 2, 1), substr (audit_ssobj_info.ex_mode, 3, 1),
		audit_ssobj_info.ex_ring_brackets);
	else call ioa_$rsnnl ("^/", temp, (0));
	P_expansion = P_expansion || temp;

	call ioa_$rsnnl (
	     "Switches: ^[^^^]dirsw,^[^^^]per_process,^[^^^]safety,^[^^^]multiple_class,^[^^^]audit,^[^^^]security_oos,^[^^^]entrypt,^[^^^]master_dir.^/"
	     ,
	     temp, (0), ^audit_ssobj_info.dirsw, ^audit_ssobj_info.per_process_sw, ^audit_ssobj_info.safety_sw,
	     ^audit_ssobj_info.multiple_class, ^audit_ssobj_info.audit_flag, ^audit_ssobj_info.security_oosw,
	     ^audit_ssobj_info.entrypt_sw, ^audit_ssobj_info.master_dir);
	P_expansion = P_expansion || temp;

	a_info_ptr = addrel (a_info_ptr, size (audit_ssobj_info));
	a_info_size = a_info_size - size (audit_ssobj_info);

	return;
     end expand_ssobj;
%page;

expand_link:
     procedure (a_info_ptr, a_info_size);

dcl     a_info_ptr		 ptr parameter;
dcl     a_info_size		 fixed bin parameter;

	audit_link_info_ptr = info_ptr;
	if info_size < size (audit_link_info)
	then goto unknown_data;

	call vpn_cv_uid_path_ (addr (audit_link_info.parent_uid_path), parent, (0));

	call ioa_$rsnnl ("Object: link ^w in ^a, DTEM is ^a^/", temp, (0),
	     audit_ssobj_info.entry_uid, parent,
	     date_time_$format ("date_time", cv_fstime_ (audit_ssobj_info.dtem), "", ""));

	P_expansion = P_expansion || temp;

	a_info_ptr = addrel (a_info_ptr, size (audit_link_info));
	a_info_size = a_info_size - size (audit_link_info);

	return;
     end expand_link;
%page;

/*	OLD ssobj and sslnk expanders		*/

expand_old_ssobj:
     procedure (a_info_ptr, a_info_size);

dcl     a_info_ptr		 ptr parameter;
dcl     a_info_size		 fixed bin parameter;

/* OLD structure declarations */
dcl     old_audit_ssobj_info_ptr
			 pointer;

dcl     1 old_audit_ssobj_info based (old_audit_ssobj_info_ptr) aligned,
	2 info_type	 char (8) unal,
	2 parent_uid_path	 (0:15) bit (36) aligned,
	2 entry_uid	 bit (36),
	2 dtem		 bit (36),
	2 raw_mode	 bit (36),
	2 ex_mode		 bit (36),
	2 access_class	 bit (72),
	2 ring_brackets	 (3) bit (3) unal,
	2 ex_ring_brackets	 (3) bit (3) unal,
	2 flags		 unal,
	  3 (
	       dirsw,
	       per_process_sw,
	       safety_sw,
	       multiple_class,
	       audit_flag,
	       security_oosw,
	       entrypt_sw,
	       master_dir
	       )		 bit (1) unal,
	  3 pad		 bit (10) unal,
	2 pad2		 bit (36) aligned;

/* slightly shorter info for links, first three components are same */

dcl     old_audit_link_info_ptr
			 pointer;

dcl     1 old_audit_link_info	 based (old_audit_link_info_ptr) aligned,
	2 info_type	 char (8) unal,
	2 parent_uid_path	 (0:15) bit (36) aligned,
	2 entry_uid	 bit (36),
	2 dtem		 bit (36);

	old_audit_ssobj_info_ptr = a_info_ptr;
	if info_size < size (old_audit_ssobj_info)
	then goto unknown_data;

	call vpn_cv_uid_path_ (addr (old_audit_ssobj_info.parent_uid_path), parent, (0));

	call ioa_$rsnnl ("Object: branch ^w in ^a, DTEM is ^a^/", temp, (0),
	     old_audit_ssobj_info.entry_uid, parent,
	     date_time_$format ("date_time", cv_fstime_ (old_audit_ssobj_info.dtem), "", ""));
	P_expansion = P_expansion || temp;

	call ioa_$rsnnl ("Raw mode: ^[null^s^s^s^;^[r^]^[e^]^[w^]^]  Ring brackets: ^d,^d,^d  Class: ^a.",
	     temp, (0), (substr (old_audit_ssobj_info.raw_mode, 1, 3) = "000"b),
	     substr (old_audit_ssobj_info.raw_mode, 1, 1), substr (old_audit_ssobj_info.raw_mode, 2, 1),
	     substr (old_audit_ssobj_info.raw_mode, 3, 1), old_audit_ssobj_info.ring_brackets,
	     display_access_class_ (old_audit_ssobj_info.access_class));
	P_expansion = P_expansion || temp;

	if substr (old_audit_ssobj_info.ex_mode, 1, 3) ^= "000"b
	     | old_audit_ssobj_info.ex_ring_brackets (1) ^= "000"b
	     | old_audit_ssobj_info.ex_ring_brackets (2) ^= "000"b
	     | old_audit_ssobj_info.ex_ring_brackets (3) ^= "000"b
	then call ioa_$rsnnl (" (Ex mode: ^[null^s^s^s^;^[r^]^[e^]^[w^]^]  Ex Ring brackets: ^d,^d,^d).^/", temp, (0),
		(substr (old_audit_ssobj_info.ex_mode, 1, 3) = "000"b), substr (old_audit_ssobj_info.ex_mode, 1, 1),
		substr (old_audit_ssobj_info.ex_mode, 2, 1), substr (old_audit_ssobj_info.ex_mode, 3, 1),
		old_audit_ssobj_info.ex_ring_brackets);
	else call ioa_$rsnnl ("^/", temp, (0));
	P_expansion = P_expansion || temp;

	call ioa_$rsnnl (
	     "Switches: ^[^^^]dirsw,^[^^^]per_process,^[^^^]safety,^[^^^]multiple_class,^[^^^]audit,^[^^^]security_oos,^[^^^]entrypt,^[^^^]master_dir.^/"
	     ,
	     temp, (0), ^old_audit_ssobj_info.dirsw, ^old_audit_ssobj_info.per_process_sw,
	     ^old_audit_ssobj_info.safety_sw,
	     ^old_audit_ssobj_info.multiple_class, ^old_audit_ssobj_info.audit_flag,
	     ^old_audit_ssobj_info.security_oosw,
	     ^old_audit_ssobj_info.entrypt_sw, ^old_audit_ssobj_info.master_dir);
	P_expansion = P_expansion || temp;

	a_info_ptr = addrel (a_info_ptr, size (old_audit_ssobj_info));
	a_info_size = a_info_size - size (old_audit_ssobj_info);

	return;


expand_old_link:
     entry (a_info_ptr, a_info_size);

	old_audit_link_info_ptr = info_ptr;
	if info_size < size (old_audit_link_info)
	then goto unknown_data;

	call vpn_cv_uid_path_ (addr (old_audit_link_info.parent_uid_path), parent, (0));

	call ioa_$rsnnl ("Object: link ^w in ^a, DTEM is ^a^/", temp, (0),
	     old_audit_ssobj_info.entry_uid, parent,
	     date_time_$format ("date_time", cv_fstime_ (old_audit_ssobj_info.dtem), "", ""));

	P_expansion = P_expansion || temp;

	a_info_ptr = addrel (a_info_ptr, size (old_audit_link_info));
	a_info_size = a_info_size - size (old_audit_link_info);

	return;

     end expand_old_ssobj;
%page;

/* procedure to keep track of the expanders we know about (to avoid repetitive
   calls to hcs_$make_entry */

expander_cache:
     procedure ();					/* this entry not used */

dcl     a_expander_index	 parameter fixed bin;
dcl     a_expander_entry	 parameter variable entry (ptr, ptr, ptr, fixed bin, char (*) varying, fixed bin (35));

expander_cache$put:					/* entry to save the entry of an expander procedure */
     entry (a_expander_index, a_expander_entry);

	if a_expander_index < 1 | a_expander_index > dimension (expander_am, 1)
	then ;					/* no place to put it */
	else do;
	     substr (expanders_known, a_expander_index, 1) = "1"b;
	     expander_am (a_expander_index) = a_expander_entry;
	end;

	return;


expander_cache$get:					/* entry to retrieve the entry of an expander procedure */
     entry (a_expander_index, a_expander_entry) returns (bit (1) aligned);

	if a_expander_index < 1 | a_expander_index > dimension (expander_am, 1)
	then return ("0"b);				/* no place it could be */

	if substr (expanders_known, a_expander_index, 1)
	then do;
	     a_expander_entry = expander_am (a_expander_index);
	     return ("1"b);
	end;
	else return ("0"b);

     end expander_cache;
%page;
%include log_message;
%page;
%include access_audit_bin_header;
%page;
%include access_audit_binary_def;
%page;
%include access_audit_encoded_op;
%page;
%include access_audit_eventflags;
%page;
%include access_audit_ssobj_info;
%page;
%include access_audit_names;

     end expand_access_audit_msg_;




		    expand_as_ia_audit_info_.pl1    07/13/88  1236.9r w 07/13/88  0943.2       47799



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

expand_as_ia_audit_info_:
        procedure (P_log_message_format_ptr, P_expand_mode_ptr, P_info_ptr,
	  P_info_size, P_expansion, P_code);

/**** This procedure expands the extended binary portion of Answering
      Service Identification and Authentication (I&A) records */

/* Written 1985-01-28 by E. Swenson */

/* Parameters */

        dcl     P_code		fixed bin (35) parameter;
					      /* status code */
        dcl     P_expand_mode_ptr	ptr parameter;
        dcl     P_expansion		char (*) varying parameter;
					      /* character string to output */
        dcl     P_info_ptr		ptr parameter;  /* pointer to I&A binary info */
        dcl     P_info_size		fixed bin (17) parameter;
					      /* size of binary info */
        dcl     P_log_message_format_ptr
				ptr parameter;

/* Automatic */

        dcl     1 abs_info		structure aligned based,
	        2 pathname		char (168),
	        2 proxy_submitter	char (32);
        dcl     attributes_str	char (256) varying;
					      /* character string representation of user attributes */
        dcl     audit_flags_str	char (256);     /* character string representation of audit flags */
        dcl     code		fixed bin (35); /* status code */
        dcl     ioa_$rsnnl		entry () options (variable);
        dcl     p			ptr;	      /* used to reference binary data */
        dcl     rest_ptr		ptr;	      /* temporary to extended binary data */
        dcl     temp		char (1024) varying;
					      /* temporary string */

/* Entries */

        dcl     convert_access_audit_flags_$to_string
				entry (bit (36) aligned, char (*),
				fixed bin (35));
        dcl     format_attributes_	entry (ptr, char (*) varying);

/* External */

        dcl     error_table_$bad_arg	fixed bin (35) external static;
        dcl     error_table_$unimplemented_version
				fixed bin (35) external static;

/* Constants */

        dcl     PROCESS_TYPES		(0:4) char (12) internal static
				options (constant)
				initial ("dial/slave", "interactive",
				"absentee", "daemon", "operator");

/* Builtin */

        dcl     addr		builtin;
        dcl     addwordno		builtin;
        dcl     divide		builtin;
        dcl     length		builtin;
        dcl     size		builtin;
        dcl     substr		builtin;

%page;
/* Program */
        p = P_info_ptr;
        if P_info_size < size (as_ia_audit_record_) then
	      do;
	      P_code = error_table_$bad_arg;
	      return;
	      end;

        if p -> as_ia_audit_record_.version ^= AS_AUDIT_RECORD_IA_VERSION_1 then
	      do;
	      P_code = error_table_$unimplemented_version;
	      return;
	      end;

        P_code = 0;
        call format_attributes_ (addr (p -> as_ia_audit_record_.attributes),
	  attributes_str);

/**** format_attributes_ places an ugly semi-colon at the end of the
      attributes.  We'll remove it for better appearance */

        if substr (attributes_str, length (attributes_str), 1) = ";" then
	      attributes_str =
		substr (attributes_str, 1, length (attributes_str) - 1);

        call convert_access_audit_flags_$to_string (p
	  -> as_ia_audit_record_.audit_flags, audit_flags_str, code);
        if code ^= 0 then
	      audit_flags_str = "-invalid-";

        call ioa_$rsnnl (
	  "Process type = ^a, Min ring = ^d, Max ring = ^d, Attributes = ""^a"", Audit flags = ""^a"", Channel = ^a, Terminal type = ^a, Answerback = ""^a""^/"
	  , temp, (0), PROCESS_TYPES (p -> as_ia_audit_record_.process_type),
	  p -> as_ia_audit_record_.min_ring,
	  p -> as_ia_audit_record_.max_ring, attributes_str, audit_flags_str,
	  p -> as_ia_audit_record_.channel,
	  p -> as_ia_audit_record_.terminal_type,
	  p -> as_ia_audit_record_.answerback);

/**** Update our string so far, and the length remaining to be processed */

        P_expansion = P_expansion || temp;
        P_info_size = P_info_size - size (as_ia_audit_record_);

/**** Handle extra information in the abs and abs_proxy records */

        if p -> as_ia_audit_record_.type ^= AAB_ia_int_dmn then
	      do;
	      rest_ptr = addwordno (p, size (as_ia_audit_record_));
	      call ioa_$rsnnl ("Absentee input path = ^a^/", temp, (0),
		rest_ptr -> abs_info.pathname);
	      P_expansion = P_expansion || temp;
	      P_info_size =
		P_info_size
		- divide (length (rest_ptr -> abs_info.pathname), 4, 17, 0);

	      if p -> as_ia_audit_record_.type = AAB_ia_abs_proxy then
		    do;
		    call ioa_$rsnnl ("Proxy submitter = ^a^/", temp, (0),
		        rest_ptr -> abs_info.proxy_submitter);
		    P_expansion = P_expansion || temp;
		    P_info_size =
		        P_info_size
		        -
		        divide (
		        length (rest_ptr -> abs_info.proxy_submitter), 4,
		        17, 0);
		    end;
	      end;
        else
	      ;

        return;

/* format: off */
%page; %include access_audit_bin_header;
%page; %include access_audit_binary_def;
%page; %include as_audit_structures;
%page; %include user_attributes;
/* format: on */

        end expand_as_ia_audit_info_;





		    expand_channel_audit_info_.pl1  07/13/88  1236.9r w 07/13/88  0943.2       42606



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

expand_channel_audit_info_:
        procedure (P_log_message_format_ptr, P_expand_mode_ptr, P_info_ptr,
	  P_info_size, P_expansion, P_code);

/**** This program expands the channel information stored in the binary
      data associated with Answering Service audit records.  */

/* Written 1985-01-28 by E. Swenson */

/* Parameters */

        dcl     P_code		fixed bin (35) parameter;
					      /* status code */
        dcl     P_expand_mode_ptr	ptr parameter;
        dcl     P_expansion		char (*) varying parameter;
					      /* character string to output */
        dcl     P_info_ptr		ptr parameter;  /* pointer to I&A binary info */
        dcl     P_info_size		fixed bin (17) parameter;
					      /* size of binary info */
        dcl     P_log_message_format_ptr
				ptr parameter;

/* Automatic */

        dcl     code		fixed bin (35); /* status code */
        dcl     ioa_$rsnnl		entry () options (variable);
        dcl     p			ptr;	      /* used to reference binary data */
        dcl     temp		char (1024) varying;
					      /* temporary string */

/* Entries */

        dcl     display_access_class_	entry (bit (72) aligned)
				returns (char (32) aligned);
        dcl     display_access_class_$range
				entry ((2) bit (72) aligned)
				returns (char (32) aligned);

/* External */

        dcl     error_table_$bad_arg	fixed bin (35) external static;
        dcl     error_table_$unimplemented_version
				fixed bin (35) external static;

/* Builtin */

        dcl     lbound		builtin;
        dcl     hbound		builtin;
        dcl     size		builtin;

%page;
/* Program */
        p = P_info_ptr;
        if P_info_size < size (as_channel_audit_record_) then
	      do;
	      P_code = error_table_$bad_arg;
	      return;
	      end;

        if p -> as_channel_audit_record_.version
	  ^= AS_AUDIT_RECORD_CHN_VERSION_1 then
	      do;
	      P_code = error_table_$unimplemented_version;
	      return;
	      end;

        P_code = 0;

/**** If a CDT entry pointer is not available at the time of the audit
      message, the channel_info_valid flag is turned on in the audit
      record.  This indicates that the only valid information is the
      channel name. */

        if p -> as_channel_audit_record_.flags.channel_info_valid then
	      do;
	      call ioa_$rsnnl (
		"Channel name = ^a, ^[Current access class = ^a, ^;^s^]Access Class Range = ^a, ^[Current Service type = ^a, ^;^s^]Service type = ^a, Terminal type = ""^a""^[, Userid = ^a.^a^;^s^s^]^/"
		, temp, (0), p -> as_channel_audit_record_.channel_name,
		p
		-> as_channel_audit_record_.flags
		.current_access_class_valid,
		display_access_class_ (p
		-> as_channel_audit_record_.current_access_class (1)),
		display_access_class_$range (p
		-> as_channel_audit_record_.access_class_range),
		(p -> as_channel_audit_record_.current_service_type
		^= p -> as_channel_audit_record_.service_type),
		DISPLAY_SERVICE_TYPE (p
		-> as_channel_audit_record_.current_service_type),
		DISPLAY_SERVICE_TYPE (p
		-> as_channel_audit_record_.service_type),
		p -> as_channel_audit_record_.terminal_type,
		p -> as_channel_audit_record_.authenticated_user.personid,
		p -> as_channel_audit_record_.authenticated_user.projectid);
	      end;
        else
	      call ioa_$rsnnl ("Channel name = ^a", temp, (0),
		p -> as_channel_audit_record_.channel_name);

/**** Update the relevant information for our caller. */

        P_expansion = P_expansion || temp;
        P_info_size = P_info_size - size (as_channel_audit_record_);

        return;
%page;
DISPLAY_SERVICE_TYPE:
        procedure (P_service_type) returns (char (*));

/**** This procedure returns a displayable representation of the
      service type of a channel. */

        dcl     P_service_type	fixed bin (17) unaligned parameter;

        dcl     SERVICE_TYPES		(9) character (10) internal
				static options (constant)
				initial ("login", "ftp", "mc", "slave",
				"dial", "dialout", "inactive", "mpx",
				"t&d");
        if P_service_type < lbound (SERVICE_TYPES, 1)
	  | P_service_type > hbound (SERVICE_TYPES, 1) then
	      return ("unknown");
        else
	      return (SERVICE_TYPES (P_service_type));

        end DISPLAY_SERVICE_TYPE;

/* format: off */
%page; %include access_audit_bin_header;
%page; %include as_audit_structures;
%page; %include user_attributes;
/* format: on */

        end expand_channel_audit_info_;





		    expand_config_deck_msg_.pl1     01/17/85  0841.8r w 01/17/85  0834.5       31977



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

/* *      EXPAND_CONFIG_DECK_MSG_
   *
   *      Expander for config deck messages logged during initialization.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare   first_cardp pointer;
declare   data_left fixed bin;
declare   field_no fixed bin;
declare   temp char (20) varying;
declare   config_card_field_in_ascii char (4) based;

declare   ioa_$rsnnl entry options (variable);

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_config_deck_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          data_left = dimension (log_message.data, 1);
          cardp = addr (log_message.data (1));

          goto COMMON;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_config_deck_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          data_left = dimension (log_message.data, 1) - 1;
          cardp = addr (log_message.data (2));

          goto COMMON;

/*  */

COMMON:
          do while (data_left > 0);
               P_expansion = P_expansion || config_card.word;

               do field_no = 1 to config_card.type_word.n_fields;
                    if (config_card.type_word.field_type (field_no) = CONFIG_STRING_TYPE) then
                         temp = addr (config_card.data_field (field_no)) -> config_card_field_in_ascii;
                    else if (config_card.type_word.field_type (field_no) = CONFIG_OCTAL_TYPE) then
                         call ioa_$rsnnl ("^o", temp, (0), binary (config_card.data_field (field_no)));
                    else if (config_card.type_word.field_type (field_no) = CONFIG_DECIMAL_TYPE) then
                         call ioa_$rsnnl ("^d.", temp, (0), binary (config_card.data_field (field_no)));
                    else if (config_card.type_word.field_type (field_no) = CONFIG_SINGLE_CHAR_TYPE) then
                         temp = substr ("abcdefgh", binary (config_card.data_field (field_no)), 1);
                    else call ioa_$rsnnl ("^w", temp, (0), config_card.data_field (field_no));

                    P_expansion = P_expansion || "  ";      /* Separate items by double blanks */
                    P_expansion = P_expansion || temp;
                    end;

               P_expansion = P_expansion || byte (10);      /* and separate cards by newlines */

               data_left = data_left - size (config_card);  /* Move on to the next card */
               cardp = addrel (cardp, size (config_card));
               end;

          return;

%page; %include log_message;
%page; %include config_deck;

          end expand_config_deck_msg_;




		    expand_dial_serv_audit_info_.pl107/13/88  1236.9r w 07/13/88  0943.2       28188



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

expand_dial_serv_audit_info_:
        procedure (P_log_message_format_ptr, P_expand_mode_ptr, P_info_ptr,
	  P_info_size, P_expansion, P_code);

/**** This program expands the extended binary information associated
      with dial service audit records in the Answering Service log. */

/* Written 1985-01-28 by E. Swenson */

/* Parameters */

        dcl     P_code		fixed bin (35) parameter;
					      /* status code */
        dcl     P_expand_mode_ptr	ptr parameter;
        dcl     P_expansion		char (*) varying parameter;
					      /* character string to output */
        dcl     P_info_ptr		ptr parameter;  /* pointer to I&A binary info */
        dcl     P_info_size		fixed bin (17) parameter;
					      /* size of binary info */
        dcl     P_log_message_format_ptr
				ptr parameter;

/* Automatic */

        dcl     code		fixed bin (35); /* status code */
        dcl     dial_server_flags	char (24);      /* temporary for flags */
        dcl     ioa_$rsnnl		entry () options (variable);
        dcl     p			ptr;	      /* used to reference binary data */
        dcl     temp		char (1024) varying;
					      /* temporary string */

/* External */

        dcl     error_table_$bad_arg	fixed bin (35) external static;
        dcl     error_table_$unimplemented_version
				fixed bin (35) external static;

/* Builtin */

        dcl     size		builtin;

%page;
/* Program */
        p = P_info_ptr;
        if P_info_size < size (as_dial_service_audit_record_) then
	      do;
	      P_code = error_table_$bad_arg;
	      return;
	      end;

        if p -> as_dial_service_audit_record_.version
	  ^= AS_AUDIT_RECORD_DIALID_VERSION_1 then
	      do;
	      P_code = error_table_$unimplemented_version;
	      return;
	      end;

        P_code = 0;

        if p -> as_dial_service_audit_record_.flags.registered_server then
	      do;
	      if p -> as_dial_service_audit_record_.flags.privileged_server
		then
		    dial_server_flags = "registered,privileged";
	      else
		    dial_server_flags = "registered";
	      end;
        else if p -> as_dial_service_audit_record_.flags.privileged_server then
	      dial_server_flags = "privileged";
        else
	      dial_server_flags = "";

        call ioa_$rsnnl (
	  "Dial qualifier = ^a, Dial server ring = ^d^[, Flags = ""^a""^]^/",
	  temp, (0), p -> as_dial_service_audit_record_.dial_qualifier,
	  p -> as_dial_service_audit_record_.dial_server_ring,
	  (dial_server_flags ^= ""), dial_server_flags);

        P_expansion = P_expansion || temp;
        P_info_size = P_info_size - size (as_dial_service_audit_record_);

        return;

%page;
%include access_audit_bin_header;
%page;
%include as_audit_structures;
%page;
%include user_attributes;
/* format: on */

        end expand_dial_serv_audit_info_;




		    expand_fnp_poll_msg_.pl1        01/17/85  0841.8r w 01/17/85  0834.5       12024



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

/* *      EXPAND_FNP_POLL_MSG_
   *
   *      Trivial expander for FNP polling messages.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_mos_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);


expand_mos_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);


          P_expansion = P_expansion || "Use fnp_data_summary to interpret this message.";
          P_expansion = P_expansion || byte (10);

          return;

%page; %include log_message;

          end expand_fnp_poll_msg_;




		    expand_hwfault_msg_.pl1         03/14/85  0834.9r   03/13/85  1026.6       53172



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

/* format: style4 */

expand_hwfault_msg_:
     procedure ();

/* *      EXPAND_HWFAULT_MSG_
   *
   *      Expander for hardware fault messages logged by FIM and others.
   *
   *      Note that this procedure does not now use a format_log_message_
   *      entrypoint to write words of octal, though it probably should....
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   *      85-01-21, EJ Sharpe: added check for old style binary to $format entry
   *	85-02-21, EJ Sharpe: use syserr_fault_msg.incl.pl1 and excise code supporting very old message formats
*/

declare  P_log_message_format_ptr pointer parameter;
declare  P_log_message_ptr pointer parameter;
declare  P_expand_mode_ptr pointer parameter;
declare  P_expansion char (*) varying parameter;
declare  P_code fixed bin (35) parameter;

declare  temp char (2000) varying;
declare  ptr_idx fixed bin;
declare  ptr_ptr pointer;

declare  expand_log_message_$append_octal entry (pointer, pointer, fixed bin, char (*) varying);
declare  expand_log_message_$unknown_syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_log_message_$unknown entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  ioa_$rsnnl entry options (variable);

declare  NEWLINE char (1) aligned internal static options (constant) init ("
");

declare  (addr, addrel, binary, dimension, size) builtin;
%page;

expand_hwfault_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	fmsgp = addr (log_message.data (1));

	if size (fault_msg) = dimension (log_message.data, 1)
	then call expand_normal_hwfault ();
	else call expand_log_message_$unknown
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;

/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_hwfault_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	fmsgp = addr (log_message.data (2));

	if ((binary (log_message.data (1)) = SB_verify_lock)
	     | (binary (log_message.data (1)) = SB_hw_fault))
	     & (size (fault_msg) = dimension (log_message.data, 1) - 1)
	then call expand_normal_hwfault ();
	else call expand_log_message_$unknown_syserr
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;
expand_normal_hwfault:
     procedure ();

	P_expansion = P_expansion || "Pointer Registers:";
	P_expansion = P_expansion || NEWLINE;

	do ptr_idx = 0 to 7;
	     ptr_ptr = addr (fault_msg.mach_cond.prs (ptr_idx));
	     call ioa_$rsnnl ("^7o|^6.3b(^d)[^d]^[^x^]", temp, (0),
		ptr_ptr -> its_unsigned.segno,
		ptr_ptr -> its.offset,
		ptr_ptr -> its_unsigned.bit_offset,
		ptr_ptr -> its_unsigned.ringno,
		(ptr_ptr -> its_unsigned.bit_offset < 10));
	     P_expansion = P_expansion || temp;
	end;
	P_expansion = P_expansion || NEWLINE;

	call ioa_$rsnnl ("x0-x7: ^( ^6.3b^)^/", temp, (0), fault_msg.mach_cond.x);
	P_expansion = P_expansion || temp;

	call ioa_$rsnnl ("a: ^.3b q: ^.3b e: ^.3b t: ^.3b ralr: ^.3b^/", temp, (0),
	     fault_msg.mach_cond.a, fault_msg.mach_cond.q, "0"b || fault_msg.mach_cond.e,
	     fault_msg.mach_cond.t, fault_msg.mach_cond.ralr);
	P_expansion = P_expansion || temp;

	call ioa_$rsnnl ("Fault Register: ^.3b^/", temp, (0), fault_msg.mach_cond.fault_reg);
	P_expansion = P_expansion || temp;

	call add_scu_data (addr (fault_msg.mach_cond.scu));

	call add_words ("EIS Info:", addr (fault_msg.mach_cond.eis_info), 8);

	call add_history_registers (addr (fault_msg.hist_reg), (addr (fault_msg.mach_cond.scu) -> scu.pad2));

	return;
     end expand_normal_hwfault;
%page;

add_scu_data:
     procedure (P_scu_ptr);

declare  P_scu_ptr pointer parameter;

	call add_words ("SCU Data:", P_scu_ptr, 8);

	return;
     end add_scu_data;
%page;

add_history_registers:
     procedure (P_hreg_ptr, P_cpu_type);

declare  P_hreg_ptr pointer parameter;
declare  P_cpu_type bit (9) parameter;


	if (P_cpu_type = ""b) then			/* Level 68 */
	     call add_words ("OU History Reg Data:", addrel (P_hreg_ptr, 0), 32);
	else call add_words ("DU/OU History Reg Data:", addrel (P_hreg_ptr, 0), 32);

	call add_words ("CU History Reg Data:", addrel (P_hreg_ptr, 32), 32);

	if (P_cpu_type = ""b) then			/* Level 68 */
	     call add_words ("DU History Reg Data:", addrel (P_hreg_ptr, 64), 32);
	else call add_words ("APU #2 History Reg Data:", addrel (P_hreg_ptr, 64), 32);

	if (P_cpu_type = ""b) then			/* Level 68 */
	     call add_words ("APU History Reg Data:", addrel (P_hreg_ptr, 96), 32);
	else call add_words ("APU #1 History Reg Data:", addrel (P_hreg_ptr, 96), 32);

	return;
     end add_history_registers;
%page;

add_words:
     procedure (P_title, P_words_ptr, P_words_count);

declare  P_title char (*) parameter;
declare  P_words_ptr pointer parameter;
declare  P_words_count fixed bin parameter;


	P_expansion = P_expansion || P_title;
	P_expansion = P_expansion || NEWLINE;

	call expand_log_message_$append_octal (P_log_message_format_ptr, P_words_ptr, P_words_count, P_expansion);

	return;
     end add_words;

/* format: off */
%page; %include log_message;
%page; %include log_message_format;
%page; %include its;
%page; %include mc;
%page; %include syserr_binary_def;
%page; %include syserr_fault_msg;

          end expand_hwfault_msg_;




		    expand_ibm3270_mde_msg_.pl1     03/14/85  1006.7r   03/13/85  1026.7       34812



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

/* format: style4 */

expand_ibm3270_mde_msg_:
     procedure ();

/* *      EXPAND_IBM3270_MDE_MSG_
   *
   *	Expander for message from ibm3270_mpx when a queue operation is attempted
   *	on a channel which already has a write operation queued.
   *
   *	85-02-21, EJ Sharpe: initial coding
*/

declare  P_log_message_format_ptr pointer parameter;
declare  P_log_message_ptr pointer parameter;
declare  P_expand_mode_ptr pointer parameter;
declare  P_expansion char (*) varying parameter;
declare  P_code fixed bin (35) parameter;

declare  temp char (2000) varying;

declare  expand_log_message_$unknown_syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_log_message_$unknown entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  ioa_$rsnnl entry options (variable);

declare  (addr, binary, dimension, size) builtin;
%page;

expand_ibm3270_mde_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	mdep = addr (log_message.data (1));

	if (size (mde) = dimension (log_message.data, 1))
	then call expand_ibm3270_mde ();
	else call expand_log_message_$unknown
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;

/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_ibm3270_mde_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	mdep = addr (log_message.data (2));

	if (binary (log_message.data (1)) = SB_ibm3270_mde)
	     & (size (mde) = dimension (log_message.data, 1) - 1)
	then call expand_ibm3270_mde ();
	else call expand_log_message_$unknown_syserr
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;
expand_ibm3270_mde:
     procedure ();


	call ioa_$rsnnl ("^/Device index=^d, name=""^a"", addr=""^a"",", temp, (0),
	     mde.devx, mde.name, mde.device_address);
	P_expansion = P_expansion || temp;
	call ioa_$rsnnl ("^/screen size=^d, line size=^d, position=^d,", temp, (0),
	     mde.screen_size, mde.line_size, mde.position);
	P_expansion = P_expansion || temp;
	call ioa_$rsnnl ("^/next_write_chan=^d, next_poll_chan=^d, next_control_chan=^d,", temp, (0),
	     mde.next_write_chan, mde.next_poll_chan, mde.next_control_chan);
	P_expansion = P_expansion || temp;
	call ioa_$rsnnl ("^/Flags=^[^;^^^]listen,^[^;^^^]dialed,^[^;^^^]printer,^[^;^^^]hndlquit,^[^;^^^]waiting_for_ready,^[^;^^^]erase_req,",
	     temp, (0), mde.listen, mde.dialed, mde.printer, mde.hndlquit, mde.waiting_for_ready, mde.erase_req);
	P_expansion = P_expansion || temp;
	call ioa_$rsnnl ("^[^;^^^]sound_alarm,^[^;^^^]control_queued,^[^;^^^]end_of_page,^[^;^^^]keyboard_restore,^[^;^^^]rawo,^[^;^^^]rawi,^[^;^^^]raw3270,^[^;^^^]raw3270_in_effect,^[^;^^^]write_queued.",
	     mde.sound_alarm, mde.control_queued, mde.end_of_page, mde.keyboard_restore, mde.rawo, mde.rawi,
	     mde.raw3270, mde.raw3270_in_effect, mde.write_queued);
	P_expansion = P_expansion || temp;

	return;

     end expand_ibm3270_mde;

/* format: off */
%page; %include log_message;
%page; %include log_message_format;
%page; %include syserr_binary_def;
%page; %include ibm3270_mpx_data;
%page; %include ibm3270_meters; /* because ibm3270_mpx_data wants it */

          end expand_ibm3270_mde_msg_;




		    expand_io_status_msg_.pl1       03/14/85  0834.9rew 03/13/85  1026.5       52263



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

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

expand_io_status_msg_:
     procedure ();

/* *      EXPAND_IO_STATUS_MSG_
   *
   *      Expander for I/O status messages logged by ioi_masked$interrupt.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   *	85-01-25, EJ Sharpe: changed name from expand_ioi_msg_
   *      85-02-10, EJ Sharpe: changed to call analyze_(device detail)_stat_
   *	85-03-05, EJ Sharpe: added ability to get arbitrary anal table if
   *			standard one can't be used.
*/

declare P_log_message_format_ptr
			 pointer parameter;
declare P_log_message_ptr	 pointer parameter;
declare P_expand_mode_ptr	 pointer parameter;
declare P_expansion		 char (*) varying parameter;
declare P_code		 fixed bin (35) parameter;

declare log_message_format_ptr pointer;
declare expand_detail	 bit (1) aligned;
declare message_type	 fixed bin;
declare dv_name		 char (8);
declare pic99		 picture "99";
declare table_ptr		 ptr;
declare anal_ptr		 ptr;
declare code		 fixed bin (35);
declare interesting		 bit (1);
declare dev		 char (3);		/* first three chars of device name */

declare temp		 char (256) varying;	/* String used in constructing output-- the longest output */
						/* line is "Detailed status", at about 120 characters */

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

declare tape_status_table_$tape_status_table_
			 ext;
declare prt_status_table_$prt_status_table_
			 ext;
declare crz_status_table_$crz_status_table_
			 ext;
declare cpz_status_table_$cpz_status_table_
			 ext;
declare disk_status_table_$disk_status_table_
			 ext;
declare opc_status_table_$opc_status_table_
			 ext;

declare ioa_$rsnnl		 entry options (variable);

declare (addr, bin, dimension, null, rtrim, size, substr, unspec)
			 builtin;

declare analyze_device_stat_$rsnnl
			 entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);
declare analyze_detail_stat_$rsnnl
			 entry (char (*), bit (36) aligned, bit (*), char (256) var, bit (1), fixed bin (35));
declare hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
%page;


expand_io_status_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_format_ptr = P_log_message_format_ptr;
	log_message_ptr = P_log_message_ptr;

	io_msgp = addr (log_message.data (1));

	if (dimension (log_message.data, 1) >= size (io_msg))
	then
	     expand_detail = "1"b;			/* Decide how much is there, hence, how much */
	else expand_detail = "0"b;			/* to expand. */

	goto COMMON;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_io_status_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_format_ptr = P_log_message_format_ptr;
	log_message_ptr = P_log_message_ptr;

	io_msgp = addr (log_message.data (2));		/* This message has data starting in word 2 */

	message_type = bin (log_message.data (1));	/* and the old syserr binary type here */

	if (message_type = SB_io_err)
	then
	     expand_detail = "0"b;
	else if (message_type = SB_io_err_detail)
	then
	     expand_detail = "1"b;
	else if (message_type = SB_ocdcm_err)
	then
	     expand_detail = "0"b;
	else if (message_type = SB_disk_err)
	then
	     expand_detail = "0"b;
	else do;					/* Not one of ours, Jack. */
	     P_code = error_table_$invalid_record_desc;
	     return;
	end;

	goto COMMON;
%page;


COMMON:

	P_expansion = "";				/* Start out empty */
	dv_name = io_msg.devname;
	dev = substr (dv_name, 1, 3);			/* the first three chars tell us what it is */
	if dev = "dsk" | dev = "tap"
	then do;
	     dv_name = rtrim (dv_name) || "_";
	     pic99 = bin (io_msg.device);
	     dv_name = rtrim (dv_name) || pic99;
	end;


	if dev = "tap"
	then table_ptr = addr (tape_status_table_$tape_status_table_);
	else if dev = "prt"
	then table_ptr = addr (prt_status_table_$prt_status_table_);
	else if dev = "rdr"
	then table_ptr = addr (crz_status_table_$crz_status_table_);
	else if dev = "pun"
	then table_ptr = addr (cpz_status_table_$cpz_status_table_);
	else if dev = "dsk"
	then table_ptr = addr (disk_status_table_$disk_status_table_);
	else if dev = "opc"
	then table_ptr = addr (opc_status_table_$opc_status_table_);
	else do;
	     call hcs_$make_ptr (null (), dev || "_status_table_", dev || "_status_table_", table_ptr, code);
	     if code ^= 0
	     then table_ptr = null ();
	end;

	call ioa_$rsnnl ("^a (chnl ^a).  ", temp, (0), dv_name, io_msg.channel);
	P_expansion = P_expansion || temp;

	if io_msg.time_out
	then temp = "Channel timed out.";
	else if io_msg.level = "001"b
	then call ioa_$rsnnl ("System fault: ^w", temp, (0), io_msg.status);
	else call analyze_device_stat_$rsnnl (temp, table_ptr, (io_msg.status), ("0"b));
	P_expansion = P_expansion || temp;

	if bin (io_msg.count) > 1
	then do;
	     call ioa_$rsnnl (" (^d times)", temp, 0, bin (io_msg.count));
	     P_expansion = P_expansion || temp;
	end;

	if expand_detail
	then do;
	     call analyze_detail_stat_$rsnnl (dv_name, io_msg.status, io_msg.detailed_status, temp, interesting, code);
	     if interesting
	     then P_expansion = P_expansion || temp;
	end;

	P_code = 0;
	return;

%page;
%include log_message;
%page;
%include io_syserr_msg;
%page;
%include syserr_binary_def;

     end expand_io_status_msg_;




		    expand_log_message_.pl1         02/19/85  1025.9r   02/14/85  0746.0       55512



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
expand_log_message_:
     procedure (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

/* *	EXPAND_LOG_MESSAGE_
   *
   *	This is the procedure used to generate the text expansions of binary
   *	data in sys log messages. Basically, it is just a wrapper for the
   *	per-message formatting routines. For efficiency's sake, it knows the
   *	names of some of them, and references them through links, but it can
   *	find all the others by calling hcs_$make_entry. It must be given a
   *	log_message_format_ptr, created by calling format_log_message_$init, which
   *	it just passes on to the per-message routines.
   *
   *      Modification history:
   *      84-07-04, W. Olin Sibert: Initial coding
   *      84-12-05, WOS: Added "syserr", corrected data class declaration to 16 chars
   *      1985-01-15, BIM: added $append_(process_id, data_class)
   *	1985-01-21, EJ Sharpe: removed "syserr", call $unknown when make_entry fails
   */

declare	P_log_message_format_ptr pointer parameter;
declare	P_log_message_ptr pointer parameter;
declare	P_expand_mode_ptr pointer parameter;
declare	P_expansion char (*) varying parameter;
declare	P_code fixed bin (35) parameter;

declare	expand_class char (16) varying;
declare	expand_proc_name char (32);
declare	expand_proc variable entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));


declare   expand_log_message_$unknown entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));

declare	hcs_$make_entry entry (pointer, char (*), char (*), entry, fixed bin (35));
declare   ioa_$rsnnl entry options (variable);

declare  (codeptr, rtrim) builtin;

/* */

	log_message_ptr = P_log_message_ptr;
	P_code = 0;
          P_expansion = "";

	if (log_message.data_lth = 0) then return;	/* Nothing to expand */

	expand_class = rtrim (log_message.data_class);

          if (expand_class = "") then expand_proc = expand_log_message_$unknown;
	else do;
	     expand_proc_name = "expand_" || expand_class || "_msg_";
	     call hcs_$make_entry (codeptr (expand_log_message_), expand_proc_name, "format", expand_proc, P_code);
	     if (P_code ^= 0) then expand_proc = expand_log_message_$unknown;
	     end;


          call expand_proc (P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;

/*  */

/* Some utility entrypoints for adding standard-format data to an expanded message. */

expand_log_message_$append_octal:
     entry (P_log_message_format_ptr, P_data_ptr, P_data_size, P_expansion);

declare   P_data_ptr pointer parameter;
declare   P_data_size fixed bin parameter;

declare   words_per_line fixed bin;
declare   available_chars fixed bin;
declare   words_ptr pointer;
declare   words_left fixed bin;
declare   words (min (words_left, words_per_line)) bit (36) aligned based (words_ptr);
declare   temp char (150) varying;


          log_message_format_ptr = P_log_message_format_ptr;

          available_chars = log_message_format.line_lth - log_message_format.continuation_indent;
          do words_per_line = 8, 4, 2, 1;
               if (available_chars > (words_per_line * (12 + 1))) then
                    goto HAVE_CORRECT_SIZE;
               end;

HAVE_CORRECT_SIZE:
          words_left = P_data_size;
          words_ptr = P_data_ptr;

          do while (words_left > 0);
               call ioa_$rsnnl ("^(^w ^)^/", temp, (0), words);
               P_expansion = P_expansion || temp;
               words_left = words_left - words_per_line;
               words_ptr = addrel (words_ptr, words_per_line);
               end;

          return;

expand_log_message_$append_process_id:
	entry (P_log_message_format_ptr, P_log_message_ptr, P_expansion);

	log_message_format_ptr = P_log_message_format_ptr;

	log_message_ptr = P_log_message_ptr;

          available_chars = log_message_format.line_lth - log_message_format.continuation_indent;

	/**** Process ID: NNNNNNNNNNNN */

	if available_chars < 24 then 
	     call ioa_$rsnnl ("PID: ^w^/", temp, (0), log_message.process_id);
	else call ioa_$rsnnl ("Process ID: ^w^/", temp, (0), log_message.process_id);
	P_expansion = P_expansion || temp;
	return;

expand_log_message_$append_data_class:
	entry (P_log_message_format_ptr, P_log_message_ptr, P_expansion);

	log_message_format_ptr = P_log_message_format_ptr;

	log_message_ptr = P_log_message_ptr;
	if log_message.data_class = "" then return; /* Nothing to add */

	call ioa_$rsnnl ("Data class: ^a^/", temp, (0), log_message.data_class);
	P_expansion = P_expansion || temp;
	return;


/*  */

expand_log_message_$unknown:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          call ioa_$rsnnl ("Unknown log message class ""^a"":^/", temp, (0), log_message.data_class);
          P_expansion = P_expansion || temp;

          call expand_log_message_$append_octal (P_log_message_format_ptr,
               addr (log_message.data (1)), dimension (log_message.data, 1), P_expansion);

          return;



/* This is a compatibility entrypoint-- it is used to process unknown messages
   in old-style "syserr" format. */

expand_log_message_$unknown_syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          call ioa_$rsnnl ("Unknown syserr message type ^d:^/", temp, (0),
               binary (log_message.data (1)));
          P_expansion = P_expansion || temp;

          call expand_log_message_$append_octal (P_log_message_format_ptr,
               addr (log_message.data (2)), (dimension (log_message.data, 1) - 1), P_expansion);

          return;

%page; %include log_message;
%page; %include log_message_format;

	end expand_log_message_;




		    expand_mdc_uidpath_msg_.pl1     03/14/85  1006.8r w 03/13/85  1026.6       29754



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

/* format: style4 */

expand_mdc_uidpath_msg_:
     procedure ();

/* *      EXPAND_MDC_UIDPATH_MSG_
   *
   *	Expander for message from Master Directory Control about the
   *	automatic deregistration of orphan or otherwise missing master directories.
   *
   *	85-02-21, EJ Sharpe: initial coding
   *	85-03-06, EJ Sharpe: change to always return 0 code
*/

declare  P_log_message_format_ptr pointer parameter;
declare  P_log_message_ptr pointer parameter;
declare  P_expand_mode_ptr pointer parameter;
declare  P_expansion char (*) varying parameter;
declare  P_code fixed bin (35) parameter;

declare  temp char (2000) varying;
declare  pathname char (256);
declare  code fixed bin (35);

declare  uidpath_ptr pointer;
declare  uidpath (0:15) bit (36) aligned based (uidpath_ptr);

declare  expand_log_message_$unknown_syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_log_message_$unknown entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  ioa_$rsnnl entry options (variable);
declare  vpn_cv_uid_path_ entry (ptr, char (*), fixed bin (35));

declare  (addr, binary, dimension, size) builtin;
%page;

expand_mdc_uidpath_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	uidpath_ptr = addr (log_message.data (1));

	if (size (uidpath) = dimension (log_message.data, 1))
	then call expand_uidpath ();
	else call expand_log_message_$unknown
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;

/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_mdc_uidpath_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	uidpath_ptr = addr (log_message.data (2));

	if (binary (log_message.data (1)) = SB_mdc_del_uidpath)
	     & (size (uidpath) = dimension (log_message.data, 1) - 1)
	then call expand_uidpath ();
	else call expand_log_message_$unknown_syserr
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;
expand_uidpath:
     procedure ();

	pathname = "";
						/* we won't try to deal with all the codes vpn_cv_uid_path_ might
						   return,  we'll just display what we have and return the code. */
	call vpn_cv_uid_path_ (uidpath_ptr, pathname, code);
	call ioa_$rsnnl ("^/Directory: ^a", temp, (0), pathname);
	P_expansion = P_expansion || temp;
	if code ^= 0 then do;
	     call ioa_$rsnnl ("^/UID path:^( ^w^)", temp, (0), uidpath);
	     P_expansion = P_expansion || temp;
	end;

	P_code = 0;
	return;

     end expand_uidpath;

/* format: off */
%page; %include log_message;
%page; %include log_message_format;
%page; %include syserr_binary_def;

          end expand_mdc_uidpath_msg_;




		    expand_mmdam_msg_.pl1           03/14/85  1006.8r   03/13/85  1026.6       23742



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

/* format: style4 */

expand_mmdam_msg_:
     procedure ();

/* *      EXPAND_MMDAM_MSG_
   *
   *      Expander for memory damage message generated by page_error and hardware_fault.
   *
   *	85-02-21, EJ Sharpe: initial coding
*/

declare  P_log_message_format_ptr pointer parameter;
declare  P_log_message_ptr pointer parameter;
declare  P_expand_mode_ptr pointer parameter;
declare  P_expansion char (*) varying parameter;
declare  P_code fixed bin (35) parameter;

declare  temp char (2000) varying;

declare  expand_log_message_$unknown_syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_log_message_$unknown entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  ioa_$rsnnl entry options (variable);

declare  (addr, binary, dimension, size) builtin;
%page;

expand_mmdam_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	mmdam_ptr = addr (log_message.data (1));

	if size (mmdam_msg) = dimension (log_message.data, 1)
	then call expand_mmdam ();
	else call expand_log_message_$unknown
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;

/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_mmdam_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;

	mmdam_ptr = addr (log_message.data (2));

	if (binary (log_message.data (1)) = SB_mmdam)
	     & (size (mmdam_msg) = dimension (log_message.data, 1) - 1)
	then call expand_mmdam ();
	else call expand_log_message_$unknown_syserr
		(P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;
expand_mmdam:
     procedure ();

	call ioa_$rsnnl ("^/Page at addr: ^oo, controller: ^a.", temp, (0), mmdam_msg.addr, mmdam_msg.ctrltag);

	P_expansion = P_expansion || temp;

	return;
     end expand_mmdam;

/* format: off */
%page; %include log_message;
%page; %include log_message_format;
%page; %include syserr_binary_def;
%page; %include syserr_mmdam_msg;

          end expand_mmdam_msg_;




		    expand_mos_msg_.pl1             01/17/85  0841.8r w 01/17/85  0834.6       15156



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

/* *      EXPAND_MOS_MSG_
   *
   *      Expander for MOS EDAC messages logged by mos_memory_check.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare   edit_mos_rscr_ entry (pointer, char (*) varying);

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_mos_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          call edit_mos_rscr_ (addr (log_message.data (1)), P_expansion);

          return;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_mos_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          call edit_mos_rscr_ (addr (log_message.data (2)), P_expansion);

          return;

%page; %include log_message;

          end expand_mos_msg_;




		    expand_mpc_poll_msg_.pl1        01/17/85  0841.8r w 01/17/85  0834.6       12024



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

/* *      EXPAND_MPC_POLL_MSG_
   *
   *      Trivial expander for MPC polling messages.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_mos_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);


expand_mos_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);


          P_expansion = P_expansion || "Use mpc_data_summary to interpret this message.";
          P_expansion = P_expansion || byte (10);

          return;

%page; %include log_message;

          end expand_mpc_poll_msg_;




		    expand_mseg_msg_audit_info_.pl1 05/13/85  1537.7r w 05/13/85  1536.0       27693



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

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

expand_mseg_msg_audit_info_:
     procedure (P_log_message_format_ptr, P_expand_mode_ptr, P_info_ptr,
	P_info_size, P_expansion, P_code);

/****
      EXPAND_MSEG_MSG_AUDIT_INFO_

      This is a secondary binary expander for log messages of the
      "access_audit" data class.  It is called by expand_access_audit_msg_
      when the extended binary data is of the proper type.

      History:
      1985-02-26, EJ Sharpe: initial coding
****/

/* Parameters */

dcl     P_code		 fixed bin (35) parameter;	/* status code */
dcl     P_expand_mode_ptr	 ptr parameter;
dcl     P_expansion		 char (*) varying parameter;	/* character string to output */
dcl     P_info_ptr		 ptr parameter;		/* pointer to binary info */
dcl     P_info_size		 fixed bin (17) parameter;	/* size of binary info */
dcl     P_log_message_format_ptr
			 ptr parameter;

/* Automatic */

dcl     code		 fixed bin (35);		/* status code */
dcl     temp		 char (1024) varying;	/* temporary string */

/* Entries */

dcl     display_access_class_	 entry (bit (72) aligned) returns (character (32) aligned);
dcl     ioa_$rsnnl		 entry () options (variable);


/* External */

dcl     error_table_$bad_arg	 fixed bin (35) external static;
dcl     error_table_$unimplemented_version
			 fixed bin (35) external static;

/* Builtin */

dcl     addr		 builtin;
dcl     size		 builtin;
%page;
/* Program */

	audit_mseg_msg_ptr = P_info_ptr;


	if P_info_size < size (audit_mseg_msg_info)
	then do;
	     P_code = error_table_$bad_arg;
	     return;
	end;

	if audit_mseg_msg_info.version ^= AUDIT_MSEG_MSG_INFO_VERSION_5
	then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	P_code = 0;

	call ioa_$rsnnl (
	     "MSEG V^d descriptor:^/Sender id=^a Sender level=^d Sender pid=^.3b^/Sender authorization=^a Sender max authorization=^a Sender audit=^.3b^/Message ID=^.3b Access class=^a",
	     temp, (0),
	     audit_mseg_msg_info.version,
	     audit_mseg_msg_info.descriptor.sender_id,
	     audit_mseg_msg_info.descriptor.sender_level,
	     audit_mseg_msg_info.descriptor.sender_process_id,
	     display_access_class_ ((audit_mseg_msg_info.descriptor.sender_authorization)),
	     display_access_class_ ((audit_mseg_msg_info.descriptor.sender_max_authorization)),
	     audit_mseg_msg_info.descriptor.sender_audit,
	     audit_mseg_msg_info.descriptor.ms_id,
	     display_access_class_ ((audit_mseg_msg_info.ms_access_class)));

	P_expansion = P_expansion || temp;

/* tell expand_access_audit_msg_ how much we've done */
	P_info_size = P_info_size - size (audit_mseg_msg_info);

	return;

/* format: off */
%page; %include access_audit_mseg_info;

        end expand_mseg_msg_audit_info_;





		    expand_pnt_audit_info_.pl1      07/13/88  1236.9r w 07/13/88  0943.2       63828



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

expand_pnt_audit_info_:
        procedure (P_log_message_format_ptr, P_expand_mode_ptr, P_info_ptr,
	  P_info_size, P_expansion, P_code);

/**** This program expands the extended binary information associated with
      PNT change audit records.  */

/* Written 1985-01-28 by E. Swenson */

/* Parameters */

        dcl     P_code		fixed bin (35) parameter;
					      /* status code */
        dcl     P_expand_mode_ptr	ptr parameter;
        dcl     P_expansion		char (*) varying parameter;
					      /* character string to output */
        dcl     P_info_ptr		ptr parameter;  /* pointer to I&A binary info */
        dcl     P_info_size		fixed bin (17) parameter;
					      /* size of binary info */
        dcl     P_log_message_format_ptr
				ptr parameter;

/* Automatic */

        dcl     code		fixed bin (35); /* status code */
        dcl     ioa_$rsnnl		entry () options (variable);
        dcl     new_pnt_info_ptr	ptr;	      /* pointer to pnt_audit_entry structure */
        dcl     p			ptr;	      /* used to reference binary data */
        dcl     temp		char (1024) varying;
					      /* temporary string */

/* Entries */

        dcl     display_access_class_	entry (bit (72) aligned)
				returns (char (32) aligned);
        dcl     display_access_class_$range
				entry ((2) bit (72) aligned)
				returns (char (32) aligned);

/* External */

        dcl     error_table_$bad_arg	fixed bin (35) external static;
        dcl     error_table_$unimplemented_version
				fixed bin (35) external static;

/* Builtin */

        dcl     addr		builtin;
        dcl     size		builtin;

%page;
/* Program */
        p = P_info_ptr;
        if P_info_size < (size (pnt_audit_record) - size (pnt_audit_entry) - 1)
	  then
	      do;
	      P_code = error_table_$bad_arg;
	      return;
	      end;

        if p -> pnt_audit_record.version ^= PNT_AUDIT_RECORD_VERSION_1 then
	      do;
	      P_code = error_table_$unimplemented_version;
	      return;
	      end;

        P_code = 0;

/**** Determine which of the possibly two pnt_audit_entry structures
      to display as "new" vs "old" data. */

        if p -> pnt_audit_record.flags.modify then
	      new_pnt_info_ptr = addr (p -> pnt_audit_record.pnt_entry_2);
        else
	      new_pnt_info_ptr = addr (p -> pnt_audit_record.pnt_entry_1);

        call ioa_$rsnnl (
	  "User id = ^a, Operation = ^a^[, Changed password^]^[, Changed network password^]^/^[Old^;New^] PNT info:^/^a^/"
	  , temp, (0), p -> pnt_audit_record.user_id, DISPLAY_OPERATION (),
	  p -> pnt_audit_record.flags.password_changed,
	  p -> pnt_audit_record.flags.network_password_changed,
	  p -> pnt_audit_record.flags.delete,
	  DISPLAY_PNT_AUDIT_ENTRY (new_pnt_info_ptr));

/**** For the modify opertation, there are two pnt_audit_entry structures
      supplied.  Process the other one. */

        if p -> pnt_audit_record.flags.modify then
	      call ioa_$rsnnl ("^aOld PNT info:^/^a^/", temp, (0), temp,
		DISPLAY_PNT_AUDIT_ENTRY (
		addr (p -> pnt_audit_record.pnt_entry_1)));

/**** Update the relevant information for our caller */

        P_expansion = P_expansion || temp;
        P_info_size = P_info_size - size (pnt_audit_record);

        return;
%page;
DISPLAY_OPERATION:
        procedure () returns (char (*));

/**** This internal procedure returns a character string representation
      of the PNT operation being interpreted. */

        if p -> pnt_audit_record.flags.add then
	      return ("add");
        else if p -> pnt_audit_record.flags.delete then
	      return ("delete");
        else if p -> pnt_audit_record.flags.modify then
	      return ("modify");
        else
	      return ("unknown");

        end DISPLAY_OPERATION;
%page;
DISPLAY_PNT_AUDIT_ENTRY:
        procedure (P_pnt_audit_entry_ptr) returns (char (*));

/**** This internal procedure displays the contents of a pnt_audit_entry
      structure */

        dcl     P_pnt_audit_entry_ptr	ptr parameter;  /* pointer to info structure */
        dcl     audit_flags_str	char (256) automatic;
					      /* representation of audit flags */
        dcl     p			ptr automatic;  /* temporary pointer */
        dcl     temp		char (512) automatic;
					      /* temporary */
        dcl     convert_access_audit_flags_$to_string
				entry (bit (36) aligned, char (*),
				fixed bin (35));

        p = P_pnt_audit_entry_ptr;

        call convert_access_audit_flags_$to_string (p
	  -> pnt_audit_entry.audit_flags, audit_flags_str, code);
        if code ^= 0 then
	      audit_flags_str = "-invalid-";

        call ioa_$rsnnl (
	  "Alias = ""^a"", Authorization range = ^a, Audit flags = ""^a"", Flags = ""^a""^[, Password timelock = ^a^]"
	  , temp, (0), p -> pnt_audit_entry.alias,
	  display_access_class_$range (p
	  -> pnt_audit_entry.authorization_range), audit_flags_str,
	  DISPLAY_PNT_FLAGS (addr (p -> pnt_audit_entry.flags)),
	  p -> pnt_audit_entry.flags.pw_time_lock,
	  DISPLAY_PASSWORD_TIMELOCK (p -> pnt_audit_entry.password_timelock));
        return (temp);
        end DISPLAY_PNT_AUDIT_ENTRY;
%page;
DISPLAY_PNT_FLAGS:
        procedure (P_pnt_flags_ptr) returns (char (*));

/**** This procedure returns a displayable representation of the
      flags in the PNT. */

        dcl     P_pnt_flags_ptr	ptr parameter;
        dcl     1 pnt_flags		like pnt_entry.public.flags
				based (P_pnt_flags_ptr);

        dcl     temp		char (256) automatic;

        call ioa_$rsnnl (
	  "^[^^^]password,^[^^^]network_pw,^[^^^]trap,^[^^^]lock,^[^^^]change,^[^^^]must_change,^[^^^]generate,^[^^^]operator,^[^^^]time_lock"
	  , temp, (0), ^pnt_flags.has_password,
	  ^pnt_flags.has_network_password, ^pnt_flags.trap, ^pnt_flags.lock,
	  pnt_flags.nochange, ^pnt_flags.must_change, ^pnt_flags.generate_pw,
	  ^pnt_flags.operator, ^pnt_flags.pw_time_lock);
        return (temp);

        end DISPLAY_PNT_FLAGS;
%page;
DISPLAY_PASSWORD_TIMELOCK:
        procedure (P_password_timelock) returns (char (*));

/**** This procedure returns the value of the password time lock,
      if there is one. */

        dcl     P_password_timelock	fixed bin (71) parameter;
        dcl     date_str		char (250) varying automatic;
        dcl     date_time_$format	entry (char (*), fixed bin (71),
				char (*), char (*))
				returns (char (250) var);

        if P_password_timelock = 0 then
	      return ("none");
        else
	      do;
	      date_str =
		date_time_$format ("date_time", P_password_timelock, "", "")
		;
	      return ((date_str));
	      end;

        end DISPLAY_PASSWORD_TIMELOCK;		      /* format: off */
%page; %include access_audit_bin_header;
%page; %include pnt_audit_record;
%page; %include pnt_entry;
%page; %include user_attributes;
/* format: on */

        end expand_pnt_audit_info_;





		    expand_rcp_obj_audit_info_.pl1  04/09/85  1353.7rew 04/08/85  1028.8       38052



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

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

expand_rcp_obj_audit_info_:
     procedure (P_log_message_format_ptr, P_expand_mode_ptr, P_info_ptr,
	P_info_size, P_expansion, P_code);

/****
      EXPAND_RCP_OBJ_AUDIT_INFO_

      This is a secondary binary expander for log messages of the
      "access_audit" data class.  It is called by expand_access_audit_msg_
      when the extended binary data is of the proper type.

      History:
      1985-02-26, EJ Sharpe: initial coding
      1985-03-19, E. Swenson to display raw mode and ring brackets
****/

/* Parameters */

dcl     P_code		 fixed bin (35) parameter;	/* status code */
dcl     P_expand_mode_ptr	 ptr parameter;
dcl     P_expansion		 char (*) varying parameter;	/* character string to output */
dcl     P_info_ptr		 ptr parameter;		/* pointer to binary info */
dcl     P_info_size		 fixed bin (17) parameter;	/* size of binary info */
dcl     P_log_message_format_ptr
			 ptr parameter;

/* Automatic */

dcl     auto_attributes	 (2) bit (72);		/* local copy of attributes */
dcl     code		 fixed bin (35);		/* status code */
dcl     temp		 char (1024) varying;	/* temporary string */
dcl     attr_str		 char (256) varying;	/* text rep of attributes */

/* Based */

dcl     based_dblwd		 (2) bit (36) based;	/* to convince ioa_ to display bit(72) values */


/* Entries */

dcl     cv_rcp_attributes_$to_string
			 entry (char (*), (2) bit (72), char (*) var, fixed bin (35));
dcl     display_access_class_$range
			 entry ((2) bit (72) aligned) returns (char (32) aligned);
dcl     ioa_$rsnnl		 entry () options (variable);


/* External */

dcl     error_table_$bad_arg	 fixed bin (35) external static;
dcl     error_table_$unimplemented_version
			 fixed bin (35) external static;

/* Builtin */

dcl     addr		 builtin;
dcl     size		 builtin;
%page;
/* Program */

	audit_rcp_obj_ptr = P_info_ptr;


	if P_info_size < size (rcp_obj_info)
	then do;
	     P_code = error_table_$bad_arg;
	     return;
	end;

	if rcp_obj_info.version ^= AUDIT_RCP_OBJ_INFO_VERSION_1
	then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	P_code = 0;

	call ioa_$rsnnl (
	     "Type: ^a^[ registry^2s^;, Name: ^a, Owner: ^a^], Access class: ^a, Raw mode = ^a^[, Ring brackets = ^d,^d^;^2s^].^/",
	     temp, (0),
	     rcp_obj_info.resource_type, rcp_obj_info.registry, rcp_obj_info.resource_name, rcp_obj_info.owner_id,
	     display_access_class_$range (rcp_obj_info.access_class),
	     SEG_ACCESS_MODE_NAMES (bin (rcp_obj_info.raw_mode)),
	     (rcp_obj_info.rcp_ring_brackets (1) ^= -1),
	     rcp_obj_info.rcp_ring_brackets (1),
	     rcp_obj_info.rcp_ring_brackets (2));

	P_expansion = P_expansion || temp;

	if ^rcp_obj_info.registry
	then do;
	     auto_attributes = rcp_obj_info.attributes;	/* following call need non-aligned version */
	     call cv_rcp_attributes_$to_string ((rcp_obj_info.resource_type), auto_attributes, attr_str, code);
	     if code ^= 0
	     then call ioa_$rsnnl ("Attributes: (Illegal) ^w^w ^w^w^/", temp, (0),
		     addr (rcp_obj_info.attributes (1)) -> based_dblwd,
		     addr (rcp_obj_info.attributes (2)) -> based_dblwd);
	     else call ioa_$rsnnl ("Attributes: ^a^/", temp, (0), attr_str);
	     P_expansion = P_expansion || temp;

	     call ioa_$rsnnl (
		"Flags: ^[^;^^^]device,^[^;^^^]volume,^[^;^^^]usage_locked,^[^;^^^]release_locked,^[^;^^^]awaiting_clear,^[^;^^^]has_acs_path^/"
		,
		temp, (0), rcp_obj_info.device, rcp_obj_info.volume, rcp_obj_info.usage_locked,
		rcp_obj_info.release_locked, rcp_obj_info.awaiting_clear, rcp_obj_info.has_acs_path);
	     P_expansion = P_expansion || temp;
	end;

/* tell expand_access_audit_msg_ how much we've done */
	P_info_size = P_info_size - size (rcp_obj_info);

	return;

/* format: off */
%page; %include access_audit_rcp_info;
%page; %include access_mode_values;

        end expand_rcp_obj_audit_info_;





		    expand_segdamage_msg_.pl1       01/17/85  0841.8r w 01/17/85  0834.6       17910



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

/* *      EXPAND_SEGDAMAGE_MSG_
   *
   *      Expander for segment damage messages logged by page control and salvagers.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare   binary_segmsg_util_ entry (pointer) returns (char (250));

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_segdamage_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          P_expansion = P_expansion || "Segment: ";
          P_expansion = P_expansion || rtrim (binary_segmsg_util_ (addr (log_message.data (1))));
          P_expansion = P_expansion || byte (10);

          return;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_segdamage_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          P_expansion = P_expansion || "Segment: ";
          P_expansion = P_expansion || rtrim (binary_segmsg_util_ (addr (log_message.data (2))));
          P_expansion = P_expansion || byte (10);

          return;

%page; %include log_message;

          end expand_segdamage_msg_;




		    expand_syserr_msg_.pl1          03/14/85  0834.9r   03/13/85  1026.5       53091



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

/* format: style4 */

expand_syserr_msg_:
     procedure ();

/* *      EXPAND_SYSERR_MSG_
   *
   *      This procedure expands old-style syserr messages, which have a data
   *      class of "syserr". It uses the value of the first word of data to
   *      determine the appropriate procedure to call, then calls it.
   *
   *      Modification history:
   *      84-12-05, W. Olin Sibert: Initial coding
   *	85-01-25, EJ Sharpe: changed expand_ioi_msg_ refs to expand_io_status_msg_
   *	85-02-21, EJ Sharpe: added expanders for SB_mmdam, SB_mdc_del_uidpath, and SB_ibm3270_mde
*/

declare  P_log_message_format_ptr pointer parameter;
declare  P_log_message_ptr pointer parameter;
declare  P_expand_mode_ptr pointer parameter;
declare  P_expansion char (*) varying parameter;
declare  P_code fixed bin (35) parameter;

declare  message_type fixed bin;
declare  expand_proc variable entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));

declare  expand_access_audit_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_config_deck_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_fnp_poll_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_hwfault_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_io_status_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_mos_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_mpc_poll_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_segdamage_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));

declare  expand_log_message_$unknown_syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_voldamage_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_vtoce_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_mmdam_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_mdc_uidpath_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
declare  expand_ibm3270_mde_msg_$syserr entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));

declare  (binary, dimension) builtin;
%page;

expand_syserr_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	log_message_ptr = P_log_message_ptr;
	P_code = 0;

	if (dimension (log_message.data, 1) = 0) then	/* Nothing to expand */
	     return;

	message_type = binary (log_message.data (1));

/* This exhaustive search is done solely to enhance readability of the program. Eventually, it
   will go away, when syserr callers are converted to use real data classes. */

/* format: off */
	call check (SB_disk_err,	expand_io_status_msg_$syserr);	/* 1 */
	call check (SB_hw_fault,	expand_hwfault_msg_$syserr);		/* 2 */
	call check (SB_io_err,	expand_io_status_msg_$syserr);	/* 3 */
	call check (SB_unused_4,	expand_log_message_$unknown_syserr);	/* 4 */
	call check (SB_mos_err,	expand_mos_msg_$syserr);		/* 5 */

	call check (SB_unused_6,	expand_log_message_$unknown_syserr);	/* 6 */
	call check (SB_unused_7,	expand_log_message_$unknown_syserr);	/* 7 */
	call check (SB_unused_8,	expand_log_message_$unknown_syserr);	/* 8 */
	call check (SB_unused_9,	expand_log_message_$unknown_syserr);	/* 9 */
	call check (SB_unused_10,	expand_log_message_$unknown_syserr);	/* 10 */

	call check (SB_zerpag,	expand_segdamage_msg_$syserr);	/* 11 */
	call check (SB_unused_12,	expand_log_message_$unknown_syserr);	/* 12 */
	call check (SB_vtoc_salv_dam,	expand_segdamage_msg_$syserr);	/* 13 */
	call check (SB_unused_14,	expand_log_message_$unknown_syserr);	/* 14 */
	call check (SB_unused_15,	expand_log_message_$unknown_syserr);	/* 15 */

	call check (SB_random_segdamage, expand_segdamage_msg_$syserr);	/* 16 */
	call check (SB_read_nc,	expand_voldamage_msg_$syserr);	/* 17 */
	call check (SB_unused_18,	expand_log_message_$unknown_syserr);	/* 18 */
	call check (SB_mdc_del_uidpath, expand_mdc_uidpath_msg_$syserr);	/* 19 */
	call check (SB_ocdcm_err,	expand_io_status_msg_$syserr);	/* 20 */

	call check (SB_mmdam,	expand_mmdam_msg_$syserr);		/* 21 */
	call check (SB_verify_lock,	expand_hwfault_msg_$syserr);		/* 22 */
	call check (SB_io_err_detail,	expand_io_status_msg_$syserr);	/* 23 */
	call check (SB_mpc_poll,	expand_mpc_poll_msg_$syserr);		/* 24 */
	call check (SB_fnp_poll,	expand_fnp_poll_msg_$syserr);		/* 25 */

	call check (SB_config_deck,	expand_config_deck_msg_$syserr);	/* 26 */
	call check (SB_vtoce,	expand_vtoce_msg_$syserr);		/* 27 */
	call check (SB_access_audit,	expand_access_audit_msg_$syserr);	/* 28 */

	/* 29 - 34 unused */

	call check (SB_ibm3270_mde,	expand_ibm3270_mde_msg_$syserr);	/* 35 */
/* format: on */

	expand_proc = expand_log_message_$unknown_syserr;

CALL_EXPANDER:
	call expand_proc (P_log_message_format_ptr, log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

	return;
%page;

check:
     procedure (P_msg_type, P_expander);

declare  P_msg_type fixed bin;
declare  P_expander entry;


	if (message_type ^= P_msg_type) then
	     return;

	expand_proc = P_expander;

	goto CALL_EXPANDER;

     end check;

/* format: off */
%page; %include log_message;
%page; %include syserr_binary_def;

          end expand_syserr_msg_;




		    expand_voldamage_msg_.pl1       01/17/85  0841.8r w 01/17/85  0834.6       18342



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

/* *      EXPAND_SEGDAMAGE_MSG_
   *
   *      Expander for segment damage messages logged by page control and salvagers.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare   binary_segmsg_util_$interpret_pvname entry (pointer) returns (char (32));

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_voldamage_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          P_expansion = P_expansion || "Volume: ";
          P_expansion = P_expansion || rtrim (binary_segmsg_util_$interpret_pvname (addr (log_message.data (1))));
          P_expansion = P_expansion || byte (10);

          return;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_voldamage_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;

          P_expansion = P_expansion || "Volume: ";
          P_expansion = P_expansion || rtrim (binary_segmsg_util_$interpret_pvname (addr (log_message.data (2))));
          P_expansion = P_expansion || byte (10);

          return;

%page; %include log_message;

          end expand_voldamage_msg_;




		    expand_vtoce_msg_.pl1           01/17/85  0841.8r w 01/17/85  0834.6       24237



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

/* *      EXPAND_VTOCE_MSG_
   *
   *      Expander for VTOCE images logged by the scavenger.
   *
   *      84-12-05, W. Olin Sibert: Initial coding, after print_syserr_msg_
   */

declare   P_log_message_format_ptr pointer parameter;
declare   P_log_message_ptr pointer parameter;
declare   P_expand_mode_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare   P_code fixed bin (35) parameter;

declare   temp char (3000) varying;
declare   fm_offset fixed bin;
declare   ioa_$rsnnl entry options (variable);
declare   expand_log_message_$append_octal entry (pointer, pointer, fixed bin, char (*) varying);

declare  (addr, dimension, length, rtrim, size, string, unspec) builtin;

/*  */

expand_vtoce_msg_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;
          vtocep = addr (log_message.data (1));

          goto COMMON;



/* This is a compatibility entrypoint-- it processes an old-format "syserr" class
   message, which has the syserr binary code in the first word of the data. */

expand_vtoce_msg_$syserr:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_expand_mode_ptr, P_expansion, P_code);

          log_message_ptr = P_log_message_ptr;
          vtocep = addr (log_message.data (2));

          goto COMMON;

/*  */

COMMON:
          fm_offset = wordno (addr (vtoce.fm)) - wordno (addr (vtoce));

          call ioa_$rsnnl ("^[Dir^;Seg^] VTOCE UID: ^w, original name: ""^a""^/VTOCE Header:^/",
               temp, (0), vtoce.dirsw, vtoce.uid, vtoce.primary_name);
          P_expansion = P_expansion || temp;
          call expand_log_message_$append_octal (P_log_message_format_ptr,
               addr (vtoce), fm_offset, P_expansion);

          call ioa_$rsnnl ("^/File map:^/^16(^2(^4(^7o^) ^)^/^)^/", temp, (0), vtoce.fm);
          P_expansion = P_expansion || temp;

          P_expansion = P_expansion || "VTOCE Permanent info:";
          P_expansion = P_expansion || byte (10);
          call expand_log_message_$append_octal (P_log_message_format_ptr,
               addrel (addr (vtoce), (fm_offset + 128)), (192 - (128 + fm_offset)), P_expansion);

          return;

%page; %include log_message;
%page; %include vtoce;

          end expand_vtoce_msg_;




		    format_log_message_.pl1         03/15/85  1129.7rew 03/15/85  1105.2      220608



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

/* *	FORMAT_LOG_MESSAGE_
   *
   *	This is the procedure for formatting the text portion of sys log 
   *	messages.  It must be used in conjunction with expand_log_message_ 
   *	to handle binary messages. Formatting log messages requires a
   *	log_message_format structure; this must be created by calling
   *	format_log_message_$init, and, when finished, freed by a call
   *	to format_log_message_$free. This log_message_format structure
   *	is then used (never modified) in all calls to
   *	format_log_message_$format, and expand_log_message_$format. 
   *	Additionally, some user-supplied binary message formatting
   *	routines may want to be aware of its contents and follow the
   *	appropriate rules if they do any fancy formatting.
   *
   *      1984-07-04, W. Olin Sibert: Initial coding
   *      1984-12-03, BIM: Fixed to respect equal_sw.
   *      1984-12-05, WOS: Added support for processing expansions.
   *      1984-12-11, BIM: Allowed LONG date and time strings.
   *	1984-12-20, WOS: Changed to make continuation_indent user-settable
   *      1984-12-26, BIM: Changed to make continuation_indent -1 mean "default" and zero ZERO.
   *      1985-01-21, BIM: Changed not to == if data is mismatched and there
   *         is expansion.
   *      1985-02-02, WOS: Changed to adjust message times for time zone and date header check.
   *	1985-03-14, Steve Herbst: Fixed boundary condition bug causing 2 newline characters in a row.
   */

declare	P_log_message_format_ptr pointer parameter;
declare	P_log_message_ptr pointer parameter;
declare	P_prev_message_ptr pointer parameter;
declare   P_expansion char (*) varying parameter;
declare	P_buffer char (*) varying parameter;
declare	P_code fixed bin (35);

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

declare	own_log_message_format bit (1) aligned;
declare	message_prefix char (200) varying;
declare	prev_message_ptr pointer;
declare   total_lines fixed bin;

declare   time_defaults_$zone_delta fixed bin (71) external static;

declare   date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) varying);
declare   date_time_$valid_format entry (char (*), fixed bin, fixed bin (35));
declare	get_system_free_area_ entry () returns (pointer);
declare   ioa_$rsnnl entry options (variable);

declare	MIN_LINE_LTH init (40) fixed bin internal static options (constant);
declare	NEWLINE char (1) unaligned internal static options (constant) init ("
");

declare  (addr, clock, divide, hbound, index, lbound, length, maxlength, min, null, reverse, search, substr, unspec) builtin;

/* */

format_log_message_$init:
     entry (P_log_message_format_ptr);

          system_area_ptr = get_system_free_area_ ();
          allocate log_message_format in (system_area) set (log_message_format_ptr);

          unspec (log_message_format) = ""b;
          log_message_format.area_ptr = system_area_ptr;
          log_message_format.caller = "<<not-set>>";
          log_message_format.line_lth = 132;                /* Assume a line-printer page */
          log_message_format.indentation = 0;
          log_message_format.continuation_indent = -1;
          log_message_format.equal_sw = "0"b;
          log_message_format.error_sw = "1"b;               /* Report errors by default */
          log_message_format.prefix = "";
          log_message_format.number_format = "^7d";
          log_message_format.time_format = "iso_time";      /* HH:MM:SS by default */
          log_message_format.date_format = "^9999yc-^my-^dm  ^da  ^za";

          call format_log_message_$adjust (log_message_format_ptr, (0)); /* Guaranteed to work, we supplied the formats */

          P_log_message_format_ptr = log_message_format_ptr;
          return;



format_log_message_$adjust:
     entry (P_log_message_format_ptr, P_code);

          log_message_format_ptr = P_log_message_format_ptr;

          P_code = 0;                                       /* Assume it worked, to begin with */

          call adjust_log_message_format ();

          return;

/*  */

adjust_log_message_format:
     procedure ();

declare   time_string char (40) varying;
declare   result char (80) varying;
declare   base_time fixed bin (71);
declare   test_time fixed bin (71);
declare   base_string char (50) varying;
declare   test_string char (50) varying;
declare   test_idx fixed bin;
declare   DATE_MODULUS (4) fixed bin (52) internal static options (constant) init
         (1f6, 60f6, 3600f6, 86400f6);                      /* In Microseconds: One second, minute, hour, or day */



/* First, see whether there is supposed to be a date break string, and 
   set it appropriately */

          if (log_message_format.date_format ^= "") then do;
               call date_time_$valid_format ((log_message_format.date_format), (0), P_code);
               if (P_code ^= 0) then                        /* Forget it */
                    return;

               call ioa_$rsnnl ("^/^[^^^dx^;^s^]^va^a^/", log_message_format.date_ioa_string, (0),
                    (log_message_format.indentation ^= 0),
                    log_message_format.indentation,
                    length (log_message_format.prefix),
                    log_message_format.prefix,
                    "^a");                                  /* This is where the date result is inserted */

/* This block of code determines when the "date" line should be printed-- 
   it is printed each time it would differ between two adjacent messages,
   and we test to see whether that happens when the second, minute, hour,
   or actual day is the breakpoint. */

               base_time = 0;                               /* Start out at zero, find where it differs */
               base_string = date_time_$format ((log_message_format.date_format), base_time, "", "");
               test_string = base_string;                   /* Break the loop when these differ */
               log_message_format.date_modulus = 0;

               do test_idx = lbound (DATE_MODULUS, 1) to hbound (DATE_MODULUS, 1)
                         while (test_string = base_string);

                    log_message_format.date_modulus = DATE_MODULUS (test_idx);
                    test_time = base_time + DATE_MODULUS (test_idx);
                    test_string = date_time_$format ((log_message_format.date_format), test_time, "", "");
                    end;
               end;
          else log_message_format.date_ioa_string = "";

/* Next, figure out the max length of the time string (via a kludge, because 
   there is no date_time_ mechanism for it yet), and save the result. */

          if (log_message_format.time_format ^= "") then do;
               call date_time_$valid_format ((log_message_format.time_format), (0), P_code);
               if (P_code ^= 0) then                        /* Forget it */
                    return;

               time_string = date_time_$format ((log_message_format.time_format), (clock ()), "", "");
               end;
          else time_string = "";

/* Construct the ioa_ string used for messages */

          call ioa_$rsnnl ("^[^^^dx^;^s^]^va^[^a ^;^s^^s^]^[^a ^;^s^^s^]^a^a",
               log_message_format.message_ioa_string, (0),
               (log_message_format.indentation ^= 0),       /* Insert only if there is an indentation */
               log_message_format.indentation,              /* Inserted as ^23x */
               length (log_message_format.prefix),          /* Inserted as literal text */
               log_message_format.prefix,                   /* Inserted only if there is a prefix defined */
               (time_string ^= ""),                         /* Create this field only if there is a time format */
               "^a",                                        /* Time: Result from date_time_$format put here */
               (log_message_format.number_format ^= ""),    /* Create this field only if there is a number format */
               log_message_format.number_format,            /* Message number: Straight ioa_ format */
               "^2d",                                       /* Severity: Always included */
               "^x");                                       /* A space always before the message text */

/* Try it out with reasonable inputs, to see how long it will be */

          call ioa_$rsnnl (log_message_format.message_ioa_string, result, (0),
               time_string, 1, 99);
          log_message_format.prefix_lth = length (result);  /* This is the length of the prefix, without the message */

          if (log_message_format.line_lth = 0) then         /* Apply a default? */
               log_message_format.line_lth = 132;
          else if (log_message_format.line_lth < MIN_LINE_LTH) then
               log_message_format.line_lth = MIN_LINE_LTH;

/* Continuation indent is chosen to allow at least a reasonable number of 
   characters in the continuation lines, without overflowing the specified
   line length. It is, however, the caller's responsibility not to overflow
   the first line by specifying too large a prefix and indentation. And, of
   course, if the caller supplies his own continuation_indent, all bets are
   off (we interpret negative numbers to mean "default". */
   
	if (log_message_format.continuation_indent >= 0) then
	     log_message_format.real_continuation_indent = log_message_format.continuation_indent;

          else if ((length (result) + MIN_LINE_LTH) > log_message_format.line_lth) then
               log_message_format.real_continuation_indent = log_message_format.line_lth - MIN_LINE_LTH;

          else log_message_format.real_continuation_indent = length (result);

          return;
          end adjust_log_message_format;

/*  */

format_log_message_$free:
     entry (P_log_message_format_ptr);

	log_message_format_ptr = P_log_message_format_ptr;

	if (log_message_format_ptr = null ()) then return;

	P_log_message_format_ptr = null ();

	system_area_ptr = log_message_format.area_ptr;
	free log_message_format in (system_area);

	return;

/* */

format_log_message_$format:
     entry (P_log_message_format_ptr, P_log_message_ptr, P_prev_message_ptr, P_expansion, P_buffer, P_code);

          log_message_format_ptr = P_log_message_format_ptr;
          log_message_ptr = P_log_message_ptr;
          prev_message_ptr = P_prev_message_ptr;
          P_code = 0;

          own_log_message_format = "0"b;
          if (log_message_format_ptr = null ()) then do;
               own_log_message_format = "1"b;
               call format_log_message_$init (log_message_format_ptr);
               end;

          call format_message_prefix ();

          if (^format_duplicate_message ()) then do;
               call format_message ("0"b);

               if (length (P_expansion) > 0) then
                    call format_message ("1"b);
               end;

          if own_log_message_format then
               call format_log_message_$free (log_message_format_ptr);

          return;

/*  */

format_message_prefix:
     procedure ();

declare   time_string char (100) varying;
declare   date_string char (200) varying;
declare   include_date bit (1) aligned;
declare   this_date fixed bin (30);
declare   previous_date fixed bin (30);



/* Get the character representation of message time, if we're to insert it */

          if (length (log_message_format.time_format) > 0) then
               time_string = date_time_$format ((log_message_format.time_format), (log_message.time), "", "");
          else time_string = "";

          call ioa_$rsnnl (log_message_format.message_ioa_string, message_prefix, (0),
               time_string, log_message.sequence, log_message.severity);

          if (length (log_message_format.date_format) = 0) then
               include_date = "0"b;
          else if (prev_message_ptr = null ()) then
               include_date = "1"b;
          else do;
               this_date = divide ((log_message.time - time_defaults_$zone_delta),
                    log_message_format.date_modulus, 34, 0);
               previous_date = divide ((prev_message_ptr -> log_message.time - time_defaults_$zone_delta),
                    log_message_format.date_modulus, 34, 0);
               include_date = (this_date ^= previous_date);
               end;

          if include_date then do;
               date_string = date_time_$format ((log_message_format.date_format), (log_message.time), "", "");
               call ioa_$rsnnl (log_message_format.date_ioa_string, date_string, (0), (date_string));
                                                            /* date_string passed by value because it is read & written */
               message_prefix = date_string || message_prefix; /* And insert the date at the front */
               end;

          return;
          end format_message_prefix;

/*  */

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

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

	if ^log_message_format.equal_sw
	then return ("0"b);

          if (log_message.text_lth ^= prev_message_ptr -> log_message.text_lth) then
               return ("0"b);

          if (log_message.text ^= prev_message_ptr -> log_message.text) then
               return ("0"b);

	if (length (P_expansion) > 0) then do; /* If there is any expansion present, assume that all the fields become interesting */
	     if (log_message.process_id ^= prev_message_ptr -> log_message.process_id)
		then return ("0"b);
	     if (log_message.data_class_lth ^= prev_message_ptr -> log_message.data_class_lth)
	          then return ("0"b);
	     if (log_message.data_lth ^= prev_message_ptr -> log_message.data_lth)
		then return ("0"b);

	     if (log_message.data_class ^= prev_message_ptr -> log_message.data_class)
		then return ("0"b);

	     if (log_message.data_lth > 0)
		then if (unspec (log_message.data) ^= unspec (prev_message_ptr -> log_message.data)) then
		return ("0"b);
	end;

          P_buffer = message_prefix;
          P_buffer = P_buffer || "==";
          P_buffer = P_buffer || NEWLINE;

          return ("1"b);
          end;

/*  */

format_message:
     procedure (P_add_expansion);

declare   P_add_expansion bit (1) aligned parameter;        /* Whether we are processing text or expansion */

declare   text_ptr pointer;                                 /* Pointer to text portion of message, for ease of use */
declare   text_used fixed bin;                              /* Amount of message text used by previous lines of message */
declare   text_lth fixed bin;                               /* Total length of message text */
declare   line_lth fixed bin;                               /* Length of the "line"-- portion of this message that will */
                                                            /* be placed into the output buffer-- adjusted for breaking */
declare   breaking_lth fixed bin;                           /* Number of chars at end of line to consider looking for */
                                                            /* place to break this line of the message-- we don't scan */
                                                            /* the entire line in order to avoid a real short piece */
                                                            /* immediately followed by a very long one. Never more */
                                                            /* than half the line length, and never more than MAX_BREAK */

declare 1 text unaligned based (text_ptr),
          2 used char (text_used),
          2 line,
            3 before char (line_lth),
            3 after char (breaking_lth);

declare   prefix_lth fixed bin;                             /* Length of string preceding text of message: starts out */
                                                            /* as length of previously formatted prefix (which may */
                                                            /* contain newlines), and is set to real_continuation_indent */
                                                            /* for the second through last lines */

declare   output_ptr pointer;                               /* Pointer to varying output string overlay */
declare   output_line_lth fixed bin;                        /* Max length of current output line (adjusted for prefix) */
declare   output_used fixed bin;                            /* Number of characters used in output */
declare   output_max_lth fixed bin;                         /* Max size of output buffer */

declare   continuation_line bit (1) aligned;                /* Set for second through last output lines */
declare 1 output aligned based (output_ptr),                /* Overlay for varying string output buffer */
          2 lth fixed bin,
          2 used char (0 refer (output.lth)) unaligned,
          2 prefix char (prefix_lth) unaligned,
          2 text_line char (line_lth) unaligned,
          2 newline char (1) unaligned;

declare   nl_idx fixed bin;                                 /* Used to find intentional line breaks in message */
declare   max_breaking_lth fixed bin;                       /* Used to calculate maximum value for breaking_lth */
declare   break_idx fixed bin;                              /* Used to find a good place to break the line */
declare   break_char char (1) unaligned;                    /* Temporary copy of char at which line is broken */

declare   text_remaining bit (1) aligned;                   /* Used to simulate DO ... UNTIL */

declare   MAX_BREAKING_LTH fixed bin internal static options (constant) init (20);
declare   ALL_BREAK_CHARS char (12) unaligned internal static options (constant) init ("([{}]) .,;:|");
declare   BREAK_BEFORE_CHARS char (3) unaligned internal static options (constant) init ("([{");

/* */

          prefix_lth = length (message_prefix);
          output_line_lth = log_message_format.line_lth - log_message_format.prefix_lth;
                                                            /* Must use raw prefix length, not the one that may */
                                                            /* include newlines and the date stamp */

          output_ptr = addr (P_buffer);                     /* Collect our output buffer */
          output_max_lth = maxlength (P_buffer);

          text_used = 0;
          breaking_lth = 0;

          if ^P_add_expansion then do;                      /* We are processing the message text this time, so */
               text_lth = length (log_message.text);        /* we start out by emptying the buffer and filling */
               text_ptr = addr (log_message.text);          /* it up with the prefix, and then the text. */

               output.lth = 0;                              /* Empty the buffer */
               output_used = 0;
               continuation_line = "0"b;                    /* The first line is NOT a continuation line */
               total_lines = 0;                             /* And we haven't formatted any lines already */
               end;

          else do;                                          /* Otherwise, we are just appending the expansion */
               text_lth = length (P_expansion);
               text_ptr = addr (substr (P_expansion, 1, 1));

               output_used = output.lth;                    /* See how much we've used already */
               continuation_line = "1"b;                    /* All lines are continuations, for the expansion */
               end;

          text_remaining = "1"b;                            /* Start the loop off right */

          do total_lines = (total_lines + 1) by 1 while (text_remaining);
               line_lth = text_lth - length (text.used);
               nl_idx = index (text.line.before, NEWLINE);
               if (nl_idx > 0) then
                    line_lth = nl_idx - 1;

               if continuation_line then do;                /* Set possibly different values for continuation lines */
                    prefix_lth = log_message_format.real_continuation_indent;
                    output_line_lth = log_message_format.line_lth - prefix_lth;
                    end;

               if (length (text.line.before) > output_line_lth) then do;
                    nl_idx = 0;                             /* Stop skipping of the final newline this time around */
                    line_lth = output_line_lth;             /* Set to maximum allowed */
                    max_breaking_lth = divide (length (text.line.before), 2, 17, 0);

                    breaking_lth = min (max_breaking_lth, MAX_BREAKING_LTH); /* Until now, this has been zero */
                    line_lth = line_lth - breaking_lth;     /* Adjust down -- line.before and line.after are now same */
                    break_idx = search (reverse (text.line.after), ALL_BREAK_CHARS); /* as line.before was previously */

                    if (break_idx = 0) then do;             /* No good choice for break character found */
                         line_lth = line_lth + breaking_lth; /* Set line length back to what it was before, and */
                         breaking_lth = 0;                  /* break arbitrarily at end of line */
                         end;

                    else do;
                         break_idx = 1 + (length (text.line.after) - break_idx); /* Convert back to forward origin */
                         line_lth = line_lth + break_idx;   /* Move the before/after break to include the break char */
                         breaking_lth = breaking_lth - break_idx;

                         break_char = substr (text.line.before, length (text.line.before), 1);
                         if (index (BREAK_BEFORE_CHARS, break_char) ^= 0) then do;
                              line_lth = line_lth - 1;      /* If it's one of these, move back a character */
                              breaking_lth = breaking_lth + 1; /* so we can include this "opening" break in the next */
                              end;                          /* line of the message */

                         breaking_lth = 0;                  /* Now, eliminate the rest of the line, putting it back */
                         end;                               /* for inclusion in the next output line */
                    end;                                    /* After this, breaking_lth is always zero */

               output_used = output.lth + length (output.prefix) + length (output.text_line) + length (output.newline);
               if (output_used > output_max_lth) then do;   /* Buffer has overflowed. Truncate at previous line */
                    return;
                    end;

               if continuation_line then                    /* For continuation lines, just insert a blank prefix */
                    output.prefix = "";                     /* to supply the indentation; otherwise, insert the */
               else output.prefix = message_prefix;         /* real prefix, including date and other info */

               output.text_line = text.line.before;
               output.newline = NEWLINE;
               output.lth = output_used;                    /* Update varying string length value */

	     if substr (output.used, output.lth - 1, 2) = NEWLINE || NEWLINE then
		output.lth = output.lth - 1;		/* prevent blank line in output */

               text_used = text_used + length (text.line.before);

               if (nl_idx > 0) then                         /* Skip embedded newlines */
                    text_used = text_used + 1;

               if (text_used >= text_lth) then              /* Stop the loop */
                    text_remaining = "0"b;

               continuation_line = "1"b;                    /* All remaining lines are continuations */
               end;                                         /* of loop through message */

          return;
          end format_message;

%page; %include log_message_format;
%page; %include log_message;

          end format_log_message_;




		    log_expand_select_.pl1          01/17/85  0841.8r w 01/17/85  0834.6       71523



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

/* *	LOG_EXPAND_SELECT_
   *
   *	This procedure is used to maintain the list of message classes and modes
   *	for expansion of log messages.  The log perusal commands all accept
   *	an optional list of message classes to be expanded; each message class
   *	can additionally include a mode string controlling the format of the
   *	expansion (interpreted by the individual expansion procedure).
   *
   *	84-07-04, W. Olin Sibert
   *      84-11-30, BIM: Added $print entrypoint
   *      84-12-05, WOS: Removed octal_sw from the mechanism
   */

declare	P_expand_select_ptr pointer parameter;
declare	P_expand_mode char (*) parameter;
declare	P_log_message_ptr pointer parameter;
declare	P_expand_sw bit (1) aligned parameter;
declare	P_mode_ptr pointer parameter;
declare	P_code fixed bin (35) parameter;
declare   P_iocb_ptr pointer;
declare   P_indent fixed bin;

declare   code fixed bin (35);
declare	expand_select_ptr pointer;
declare	alloc_expand_select_max_entries fixed bin;
declare	expand_select_area area based (expand_select.area_ptr);
declare   mode_string char (500);

declare 1 expand_select aligned based (expand_select_ptr),
	2 max_entries fixed bin,
	2 n_entries fixed bin,
	2 area_ptr pointer,
	2 array (alloc_expand_select_max_entries refer (expand_select.max_entries)),
	  3 class char (16) varying,
	  3 mode_ptr pointer;

declare	data_class char (16) varying;
declare	entry_found bit (1) aligned;
declare	entry_idx fixed bin;
declare	mode_string_delim fixed bin;

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

declare   ioa_$ioa_switch entry() options(variable);
declare	get_system_free_area_ entry () returns (pointer);
declare	mode_string_$parse entry (char (*), pointer, pointer, fixed bin (35));
declare   mode_string_$get entry (pointer, character (*), fixed binary (35));

declare	ALPHANUMERIC char (37) internal static options (constant) init ("_0123456789abcdefghijklmnopqrstuvwxyz");

declare  (index, length, null, substr, verify) builtin;

/* */

log_expand_select_$add:
     entry (P_expand_select_ptr, P_expand_mode, P_code);

	expand_select_ptr = P_expand_select_ptr;

	mode_string_delim = index (P_expand_mode, ":");	/* Figure out where the mode string, if any, is located, */
	if (mode_string_delim = 0) then		/* and extract the message type from before it */
	     data_class = P_expand_mode;
	else data_class = substr (P_expand_mode, 1, mode_string_delim - 1);

	if (data_class = "") | (length (data_class) > 12) | (verify (data_class, ALPHANUMERIC) ^= 0) then do;
	     P_code = error_table_$log_message_invalid_type;
	     return;
	     end;

	if (expand_select_ptr = null ()) then		/* Allocate a new one even though we only *might* need it */
	     expand_select_ptr = make_new_table (10);	/* If we're replacing an existing entry, this will result */
	else if (expand_select.n_entries >= expand_select.max_entries) then	/* in at most one extra entry */
	     expand_select_ptr = make_new_table (10 + expand_select.max_entries);

	entry_found = "0"b;
	do entry_idx = 1 to expand_select.n_entries while (^entry_found);
	     if (expand_select.class (entry_idx) = data_class) then entry_found = "1"b;
	     end;

	if (entry_idx > expand_select.n_entries) then do; /* A new entry is required. Initialize it */
	     expand_select.class (entry_idx) = data_class;
	     expand_select.mode_ptr (entry_idx) = null (); /* This will be initialized later, as required */
	     expand_select.n_entries = entry_idx;
	     end;

	else do;					/* Existing entry is being replaced */
	     if (mode_string_delim > 0) then		/* Flush the old mode string if a new one is provided */
		if (expand_select.mode_ptr (entry_idx) ^= null ()) then do;
		     mode_string_info_ptr = expand_select.mode_ptr (entry_idx);
		     expand_select.mode_ptr (entry_idx) = null ();
		     free mode_string_info_ptr -> mode_string_info in (expand_select_area);
		     end;
	     end;

	if (mode_string_delim > 0) & (mode_string_delim < length (P_expand_mode)) then do;
	     call mode_string_$parse (substr (P_expand_mode, (mode_string_delim + 1)),
		expand_select.area_ptr, mode_string_info_ptr, P_code);
	     if (P_code ^= 0) then return;		/* Punt if any error occurs converting */
	     expand_select.mode_ptr (entry_idx) = mode_string_info_ptr;
	     end;

	P_expand_select_ptr = expand_select_ptr;	/* All done. Tell caller where the structure is */
	P_code = 0;
	return;

/* */

log_expand_select_$free:
     entry (P_expand_select_ptr);

	expand_select_ptr = P_expand_select_ptr;

	if (expand_select_ptr = null ()) then return;	/* Nothing there */

	P_expand_select_ptr = null ();		/* Don't call us again */

	do entry_idx = 1 to expand_select.n_entries;
	     mode_string_info_ptr = expand_select.mode_ptr (entry_idx);
	     expand_select.mode_ptr (entry_idx) = null ();
	     if (mode_string_info_ptr ^= null ()) then
		free mode_string_info_ptr -> mode_string_info in (expand_select_area);
	     end;

	free expand_select in (expand_select_area);

	return;

/* */

log_expand_select_$test:
     entry (P_expand_select_ptr, P_log_message_ptr, P_expand_sw, P_mode_ptr);

	expand_select_ptr = P_expand_select_ptr;
	log_message_ptr = P_log_message_ptr;

	P_expand_sw = "1"b;				/* Set output argument to default values */
	P_mode_ptr = null ();

	if (expand_select_ptr = null ()) then return;
	if (expand_select.n_entries = 0) then return;

	do entry_idx = 1 to expand_select.n_entries;	/* See if it's one we were asked about */
	     if (expand_select.class (entry_idx) = log_message.data_class) then do;
		P_mode_ptr = expand_select.mode_ptr (entry_idx);
		return;
		end;
	     end;

	P_expand_sw = "0"b;				/* If we had some to try, and this wasn't one of them, */
	return;					/* then it's not to be expanded. */

/*  */

log_expand_select_$print:
	entry (P_expand_select_ptr, P_iocb_ptr, P_indent);

	expand_select_ptr = P_expand_select_ptr;
	if expand_select_ptr = null ()
	then return;

	if expand_select.n_entries = 0 then return;
	call ioa_$ioa_switch (P_iocb_ptr, "^vxExpansion control:", P_indent);
	do entry_idx = 1 to expand_select.n_entries;
	     if expand_select.array (entry_idx).mode_ptr = null ()
	     then mode_string = "";
	     else do;
		call mode_string_$get (expand_select.array (entry_idx).mode_ptr, mode_string, code);
		if code ^= 0 then mode_string = "<bad modes>";
	     end;
               call ioa_$ioa_switch (P_iocb_ptr, "^vx  ^a^[ modes ^a^]",
		P_indent, expand_select.array (entry_idx).class,
		mode_string ^= "",
		mode_string);
	end;
	return;

/* */

make_new_table:
     procedure (P_size) returns (pointer);

declare	P_size fixed bin parameter;

declare	new_ptr pointer;
declare	system_area_ptr pointer;
declare	system_area area based (system_area_ptr);
declare	copy_idx fixed bin;


	alloc_expand_select_max_entries = P_size;
	if (expand_select_ptr = null ()) then
	     system_area_ptr = get_system_free_area_ ();
	else system_area_ptr = expand_select.area_ptr;

	allocate expand_select in (system_area) set (new_ptr);
	new_ptr -> expand_select.area_ptr = system_area_ptr;	/* used for all future allocations */

	if (expand_select_ptr ^= null ()) then do;
	     do copy_idx = 1 to expand_select.n_entries;
		new_ptr -> expand_select.array (copy_idx) = expand_select.array (copy_idx);
		end;
	     new_ptr -> expand_select.n_entries = expand_select.n_entries;
	     free expand_select in (system_area);
	     end;

	else new_ptr -> expand_select.n_entries = 0;

	return (new_ptr);
	end make_new_table;

%page; %include log_message;
%page; %include mode_string_info;

	end log_expand_select_;




		    log_format_time_.pl1            11/29/84  1142.5r w 11/28/84  0942.1        8415



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
log_format_time_:
     procedure (P_time) returns (char (32) varying);

/* *	LOG_FORMAT_TIME_
   *
   *	Repository of standard formats for log time printing; just a bunch of
   *	writearounds for date_time_$format, in more convenient form.
   *
   *	84-08-03, W. Olin Sibert: Initial coding
   *	84-10-30, WOS: Converted to date_time_$format
   */

declare	P_time fixed bin (71) parameter;

declare	date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) varying);

/* */

	return (date_time_$format ("^9999yc-^my-^dm ^Hd:^MH:^99.(6)9UM", P_time, "", ""));

	end log_format_time_;




		    log_limit_scan_.pl1             02/27/89  1206.0rew 02/27/89  1051.0      141894



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


/****^  HISTORY COMMENTS:
  1) change(89-01-16,TLNguyen), approve(89-01-16,MCR8046),
     audit(89-02-03,Parisek), install(89-02-27,MR12.3-1015):
     Set sci_ptr value before referencing the it.
                                                   END HISTORY COMMENTS */


log_limit_scan_:
     procedure (P_caller_sci_ptr, P_log_limit_info_ptr, 
	      P_reverse_sw, P_log_read_ptr);

/* *	LOG_LIMIT_SCAN_
   *
   *	This procedure is used by log-scanning programs to implement the 
   *	-to / -from / -for / -last control arguments. See print_sys_log
   *	for an example of its use. 
   *
   *	Modification history:
   *	84-08-23, W. Olin Sibert: Initial coding
   *      1984-12-10, BIM: remove the entry variables, convert to ssu_.
   *      1984-12-16, BIM: added hold/free message calls for inner ring logs.
   *	1985-03-11, Steve Herbst: Fixed to say "Log is empty." if so.
   *	1985-04-04, Steve Herbst: Fixed -from N, -to N to allow for
   *		missing sequence numbers in log.
   *	1985-05-01, Steve Herbst: Fixed bug that returned the msgs before
   *		and after the range if none in range.
   */

declare	P_caller_sci_ptr pointer;
declare	P_log_limit_info_ptr pointer parameter;
declare	P_reverse_sw bit (1) aligned parameter;
declare	P_log_read_ptr pointer parameter;

declare	(FROM_TYPE init (1), TO_TYPE init (2)) fixed bin int static options (constant);

declare	code fixed bin (35);
declare   sci_ptr pointer;
declare	log_read_ptr pointer;

declare 1 opt aligned automatic,
	2 to_number fixed bin (35),
	2 from_number fixed bin (35),
	2 for_number fixed bin (35),
	2 last_number fixed bin (35),
	2 to_time fixed bin (71),
	2 from_time fixed bin (71),
	2 for_time fixed bin (71),
	2 last_time fixed bin (71);

declare	to_given bit (1) aligned;
declare	from_given bit (1) aligned;
declare	for_given bit (1) aligned;
declare	last_given bit (1) aligned;
declare	none_given bit (1) aligned;

declare	error_table_$bad_conversion fixed bin (35) external static;
declare	error_table_$inconsistent fixed bin (35) external static;
declare	error_table_$no_log_message fixed bin (35) external static;
declare   error_table_$unimplemented_version fixed bin(35) ext static;

declare	cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
declare	convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
declare	convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));

declare   log_read_$free_message entry (pointer, pointer);
declare   log_read_$hold_message entry (pointer, pointer);
declare   log_read_$position_sequence entry (pointer, fixed binary (35), bit (1) aligned, pointer,
	fixed binary (35));
declare   log_read_$position_time entry (pointer, fixed binary (71), bit (1) aligned, pointer, fixed binary (35));
declare	log_format_time_ entry (fixed bin (71)) returns (char (32) varying);
declare   ssu_$abort_line entry options(variable);

declare	AFTER init (1) fixed bin internal static options (constant);
declare	BEFORE init (-1) fixed bin internal static options (constant);

declare  (clock, max, null) builtin;

/* */

	log_limit_info_ptr = P_log_limit_info_ptr;
	log_read_ptr = P_log_read_ptr;
	sci_ptr = P_caller_sci_ptr;

	if log_limit_info.version ^= LOG_LIMIT_INFO_VERSION_1
	then call ssu_$abort_line (sci_ptr, error_table_$unimplemented_version, "Invalid version ^a in call to log_limit_scan_.", log_limit_info.version);

	call get_time_or_number ("-from", log_limit_info.from_opt, opt.from_time, opt.from_number);
	call get_time_or_number ("-to", log_limit_info.to_opt, opt.to_time, opt.to_number);
	call get_time_or_number ("-for", log_limit_info.for_opt, opt.for_time, opt.for_number);
	call get_time_or_number ("-last", log_limit_info.last_opt, opt.last_time, opt.last_number);

	call check_consistency ();

	call find_message_limits ();

MAIN_RETURN:
	return;

/* */

check_consistency:
     procedure ();

/* The get_time_or_number procedure has already made sure that only one of each of these is true */

	to_given = (opt.to_number >= 0) | (opt.to_time >= 0);
	from_given = (opt.from_number >= 0) | (opt.from_time >= 0);
	for_given = (opt.for_number >= 0) | (opt.for_time >= 0);
	last_given = (opt.last_number >= 0) | (opt.last_time >= 0);
	none_given = ^(to_given | from_given | for_given | last_given);

/* Reject the impossible combinations of control arguments */

	if to_given & for_given then call inconsistent ("-to and -for");
	if to_given & last_given then call inconsistent ("-to and -last");
	if from_given & last_given then call inconsistent ("-from and -last");
	if for_given & last_given then call inconsistent ("-for and -last");
	if for_given & ^from_given then call inconsistent ("-for and not -from");

/* There are six valid combinations remaining after this filtering:
       1) No specifiers at all     - Whole log
       2) -to      alone	     - Beginning up to limit
       3) -from    alone	     - Limit up to now
       4) -last    alone	     - Now minus limit until now
       5) -from    and     -to     - Limit-1 to Limit-2
       6) -from    and     -for    - Limit-1 to Limit-1 plus Limit-2
   This is additionally complicated by cases 4 & 6, which must count *matching*
   messages, rather than simply doing arithmetic on message numbers.
   */

	return;
	end check_consistency;

/* */

find_message_limits:
     procedure ();

declare	from_relative_time fixed bin (71);
declare	last_time_delta fixed bin (71);
declare	exchange_ptr pointer;

declare 1 first_message aligned like log_message.header based (log_limit_info.first_msg);
declare 1 last_message aligned like log_message.header based (log_limit_info.last_msg);


	log_limit_info.first_msg = null ();
	log_limit_info.last_msg = null ();
	log_limit_info.msg_count = -1;

/* First, see if we have absolute numeric or time values for any of the limits,
   and find the appropriate messages for the limits. */

	if (opt.to_number >= 0) then do;
	     call free_message (log_limit_info.last_msg);
	     log_limit_info.last_msg = find_message_number (opt.to_number, TO_TYPE);
	     call hold_message (log_limit_info.last_msg);
	end;

	if (opt.from_number >= 0) then do;
	     call free_message (log_limit_info.first_msg);
	     log_limit_info.first_msg = find_message_number (opt.from_number, FROM_TYPE);
	     call hold_message (log_limit_info.first_msg);
	end;

	if (opt.to_number >= 0) & (opt.from_number >= 0) &
	     (log_limit_info.last_msg ^= null) & (log_limit_info.first_msg ^= null) then
		if log_limit_info.first_msg -> log_message.time > log_limit_info.last_msg -> log_message.time then
		     call ssu_$abort_line (sci_ptr, 0, "No messages within specified sequence range.");

/* And now the time range */
	     
	if (opt.to_time >= 0) then do;
	     call free_message (log_limit_info.last_msg);
	     log_limit_info.last_msg = find_message_time (opt.to_time, BEFORE);
	     call hold_message (log_limit_info.last_msg);
	end;

	if (opt.from_time >= 0) then do;
	     call free_message (log_limit_info.first_msg);
	     log_limit_info.first_msg = find_message_time (opt.from_time, AFTER);
	     call hold_message (log_limit_info.first_msg);
	end;

	if (opt.to_time >= 0) & (opt.from_time >= 0) &
	     (log_limit_info.last_msg ^= null) & (log_limit_info.first_msg ^= null) then
		if log_limit_info.first_msg -> log_message.time > log_limit_info.last_msg -> log_message.time then
		     call ssu_$abort_line (sci_ptr, 0, "No messages within specified time range.");

/* Second, calculate any of the implied absolute limits */

	if none_given then do;			/* These calls are guaranteed to succeed */
	     call free_message (log_limit_info.first_msg);
	     call free_message (log_limit_info.last_msg);
	     log_limit_info.first_msg = find_message_time (0, AFTER);
	     log_limit_info.last_msg = find_message_time (clock (), BEFORE);
	     call hold_message (log_limit_info.first_msg);
	     call hold_message (log_limit_info.last_msg);
	end;

	if from_given & ^(to_given | for_given) then do;
	     call free_message (log_limit_info.last_msg);
	     log_limit_info.last_msg = find_message_time (clock (), BEFORE);
	     call hold_message (log_limit_info.last_msg);
	end;

	if to_given & ^from_given then do;
	     call free_message (log_limit_info.first_msg);
	     log_limit_info.first_msg = find_message_time (0, AFTER);
	     call hold_message (log_limit_info.first_msg);
	end;

/* Third, if we have relative limit numbers, set the limit counter to so indicate */

	if (opt.last_number > 0) then do;
	     log_limit_info.msg_count = opt.last_number;
	     call free_message (log_limit_info.last_msg);
	     log_limit_info.last_msg = find_message_time (clock (), BEFORE);
	     call hold_message (log_limit_info.last_msg);
	     end;

	if (opt.for_number > 0) then
	     log_limit_info.msg_count = opt.for_number;

/* Finally, handle the relative limits: -for TIME and -last TIME; these must be
   recalculated explicitly now that we know the relevant message start limits.
   Note that this is why we squirreled away the character representations of the
   argument for -for. */

	if (opt.for_time >= 0) then do;		/* Turn -for into a relative time if appropriate */
	     if (opt.from_time >= 0) then		/* We are guaranteed to have a -from time or message number */
		from_relative_time = opt.from_time;	/* here, and therefore to have a valid first_message ptr */
	     else from_relative_time = first_message.time;
						/* If it's a message number we have */

						/* we get the time out of the message. */

               call convert_date_to_binary_$relative ((log_limit_info.for_opt), opt.for_time, from_relative_time, code);
	     if (code ^= 0) then 	/* Shouldn't happen, since it worked before */
		call ssu_$abort_line (sci_ptr, code, "-for ^a after ^a",
		     log_limit_info.for_opt, log_format_time_ (from_relative_time));

	     call free_message (log_limit_info.last_msg);
	     log_limit_info.last_msg = find_message_time (opt.for_time, BEFORE);
	     call hold_message (log_limit_info.last_msg);
	     end;

	if (opt.last_time >= 0) then do;		/* Turn -last into backwards offset from now */
	     from_relative_time = clock ();		/* We have to subtract it from the one we have */
	     call free_message (log_limit_info.last_msg);
	     log_limit_info.last_msg = find_message_time (from_relative_time, BEFORE);
	     call hold_message (log_limit_info.last_msg);
	     last_time_delta = max (0, (opt.last_time - from_relative_time));
	     call free_message (log_limit_info.first_msg);
	     log_limit_info.first_msg = find_message_time ((from_relative_time - last_time_delta), BEFORE);
	     call hold_message (log_limit_info.first_msg);
	     end;

/* We also must exchange the limits in case something is out of sequence */

	if (log_limit_info.first_msg ^= null ()) then
	     if (log_limit_info.last_msg ^= null ()) then
		if (first_message.sequence > last_message.sequence) then
		     if (first_message.time > last_message.time) then do;
			exchange_ptr = log_limit_info.first_msg;
			log_limit_info.first_msg = log_limit_info.last_msg;
			log_limit_info.last_msg = exchange_ptr;
			end;

/* Some validity checks in case the amazing mess above does not, in fact, work. */

	if (log_limit_info.first_msg = null ()) & (log_limit_info.last_msg = null ()) then 
	     call ssu_$abort_line (sci_ptr, 0, "Internal error in log_limit_scan_: first and last message pointers are both null.");

	if ((log_limit_info.first_msg = null ()) | (log_limit_info.last_msg = null ())) & (log_limit_info.msg_count < 0) then 
	     call ssu_$abort_line (sci_ptr, 0, "Internal error in log_limit_scan_: null first/last message pointer and no limit count.");

/* NOTE: THESE TESTS REMOVED 84-09-30 BECAUSE THEY SEEMED LIKE A POOR IDEA
	if (log_limit_info.first_msg = null ()) & ^P_reverse_sw then
	     call inconsistent ("No initial message specified and not -reverse.");

	if (log_limit_info.last_msg = null ()) & P_reverse_sw then
	     call inconsistent ("No final message specified and -reverse.");
*******/

	return;
	end find_message_limits;

/* */

find_message_number:
     procedure (P_number, P_arg_type) returns (pointer);

declare	(P_number, number) fixed bin (35);
declare	(P_arg_type, i) fixed bin;

declare	msg_ptr pointer;


	number = P_number;
	code = 1;

	do i = 1 to 20 while (code ^= 0);		/* allow 20 missing sequence numbers in log */

	     call log_read_$position_sequence (log_read_ptr, number, "0"b, msg_ptr, code);

	     if (code = 0) then			/* Require an exact match for this subroutine */
		if (msg_ptr -> log_message.sequence ^= number) then
		     code = error_table_$no_log_message;

	     if (code ^= 0) then			/* might be due to a missing sequence number */
		if P_arg_type = TO_TYPE then number = number - 1;  /* settle for message before that */
		else number = number + 1;		/* or, for -from, the one after that */
	end;

	if (code ^= 0) then 
	     call ssu_$abort_line (sci_ptr, code, "Cannot find message at or ^[before^;after^] #^d",
		P_arg_type = TO_TYPE, P_number);

	return (msg_ptr);
	end find_message_number;



find_message_time:
     procedure (P_time, P_direction) returns (pointer);

declare	P_time fixed bin (71);
declare	P_direction fixed bin;

declare	msg_ptr pointer;


	call log_read_$position_time (log_read_ptr, P_time, (P_direction = AFTER), msg_ptr, code);

	if (code ^= 0) then
	     if P_time = 0 then call ssu_$abort_line (sci_ptr, code, "Log is empty.");
	     else call ssu_$abort_line (sci_ptr, code, "Cannot find message ^[after^;before^] ^a",
		(P_direction = AFTER), log_format_time_ (P_time));

	return (msg_ptr);
	end find_message_time;

/* */

get_time_or_number:
     procedure (P_arg_name, P_arg, P_time, P_number);

declare	P_arg_name char (10) parameter;
declare	P_arg char (50) varying parameter;
declare	P_time fixed bin (71) parameter;
declare	P_number fixed bin (35) parameter;

declare	time fixed bin (71);
declare	number fixed bin (35);


	P_time = -1;
	P_number = -1;

	if (P_arg = "") then return;			/* This argument not specified */

          number = cv_dec_check_ ((P_arg), code);
	if (code = 0) then do;
	     if (number <= 0) then 
		call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
		"Message number for ^a must be > 0: ^a", P_arg_name, P_arg);
	     
	     P_number = number;
	     return;
	end;

          call convert_date_to_binary_ ((P_arg), time, code);
	if (code ^= 0) then 
	     call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
		"Invalid ^a message number/time: ^a", P_arg_name, P_arg);

	P_time = time;				/* It's a time value, instead */
	return;

	end get_time_or_number;

/* */

inconsistent:
     procedure (P_message);

declare	P_message char (*) parameter;


	call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^a", P_message);

	end inconsistent;

free_message:
	procedure (P_message_ptr);
declare P_message_ptr pointer;

	if P_message_ptr = null () then return;
	call log_read_$free_message (log_read_ptr, P_message_ptr);
	P_message_ptr = null ();
	return;
	end free_message;


hold_message:
	procedure (P_message_ptr);
declare P_message_ptr pointer;

	call log_read_$hold_message (log_read_ptr, P_message_ptr);
	return;
	end hold_message;

       

%page; %include log_message;
%page; %include log_limit_info;

	end log_limit_scan_;




		    log_match_.pl1                  02/19/85  1025.9r w 02/14/85  0747.0       79164



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

/* *	LOG_MATCH_
   *
   *	This procedure is in charge of selecting messages from a log.
   *	Given a message, it returns true or false, depending on whether
   *	the message matches the criteria established by earlier calls
   *	that created the lmd ("log match data") structure. This procedure
   *	implements selection by matching/exclusion on the message text,
   *	matching/exclusion on the formatted data, and the severity and
   *	severity class of the message.
   *
   *	It is completely responsible for maintaining the lmd data structure;
   *	this is allocated when first needed, and reallicated as required. For
   *	string matching, it relies on the procedure match_strings_ to do
   *	the necessary management; two sets of strings are maintained, one
   *	for message text, and one for expanded message data.
   *
   *	84-06-08, W. Olin Sibert
   * Modified 1984-10-24 BIM for $print.
   * Modified 1984-11-30 BIM to indent value in $print.
   * Modified 1985-01-16, BIM: added data_class support.
   */

declare	P_IOCB_ptr pointer parameter;
declare	P_log_message_ptr pointer parameter;
declare	P_expanded_string char (*) varying parameter;
declare	P_lmd_ptr pointer parameter;
declare	P_min_severity fixed bin parameter;
declare	P_max_severity fixed bin parameter;
declare	P_string char (*) parameter;
declare   P_indent fixed bin;

declare	lmd_ptr pointer;
declare	lmd_area area based (lmd_ptr);
declare 1 lmd aligned based (lmd_ptr),
	2 area_ptr pointer,
	2 text_string_ptr pointer,
	2 data_string_ptr pointer,
	2 data_class_string_ptr pointer,
	2 select_severity bit (1) aligned,
	2 severity (-256 : 255) bit (1) unaligned;

declare	severity_idx fixed bin;
declare	min_severity fixed bin;
declare	max_severity fixed bin;

declare	get_system_free_area_ entry () returns (pointer);
declare	ioa_$ioa_switch entry() options(variable);
declare   ioa_$rsnnl entry() options(variable);
declare	match_strings_$add entry (pointer, bit (1) aligned, char (*));
declare	match_strings_$free entry (pointer);
declare	match_strings_$test entry (pointer, char (*)) returns (bit (1) aligned);
declare	match_strings_$print entry (pointer /* IOCB */, fixed bin /* indent */, char (*) /* Title */, pointer /* match data */);

declare  (addr, hbound, lbound, length, max, min, null, string, unspec) builtin;

/* */

log_match_$test:
     entry (P_lmd_ptr, P_log_message_ptr, P_expanded_string) returns (bit (1) aligned);

	lmd_ptr = P_lmd_ptr;
	log_message_ptr = P_log_message_ptr;

	if (lmd_ptr = null ()) then return ("1"b);

/* This may not be the optimal ordering for these tests, but it's a reasonable first cut.
   84-07-02, WOS */

	if lmd.select_severity then
	     if ^lmd.severity (log_message.severity) then
		return ("0"b);

	if lmd.text_string_ptr ^= null () then
	     if ^match_strings_$test (lmd.text_string_ptr, log_message.text) then
	          return ("0"b);

	if lmd.data_class_string_ptr ^= null () then
	     if ^match_strings_$test (lmd.data_class_string_ptr, (log_message.data_class)) then
	          return ("0"b);

	if lmd.data_string_ptr ^= null () then 
	     if (log_message.data_lth > 0) then
	          if (length (P_expanded_string) > 0) then begin;
		     declare nv_expanded_string char (length (P_expanded_string)) based (exsp_ptr);
		declare exsp_ptr pointer;
		     exsp_ptr = addwordno (addr (P_expanded_string), 1);
		     if ^match_strings_$test (lmd.data_string_ptr, nv_expanded_string) then
		         return ("0"b);
		end;
	return ("1"b);

/* */

log_match_$free:
     entry (P_lmd_ptr);

	lmd_ptr = P_lmd_ptr;
	P_lmd_ptr = null ();

	if (lmd_ptr = null ()) then return;		/* Nothing to do */

	call match_strings_$free (lmd.text_string_ptr);

	call match_strings_$free (lmd.data_string_ptr);

	call match_strings_$free (lmd.data_class_string_ptr);

	free lmd in (lmd_area);

	return;

/* */

log_match_$add_match:
     entry (P_lmd_ptr, P_string);

	call get_caller_lmd ();
	call match_strings_$add (lmd.text_string_ptr, "1"b, P_string);
	return;



log_match_$add_exclude:
     entry (P_lmd_ptr, P_string);

	call get_caller_lmd ();
	call match_strings_$add (lmd.text_string_ptr, "0"b, P_string);
	return;


log_match_$add_match_data_class:
     entry (P_lmd_ptr, P_string);

	call get_caller_lmd ();
	call match_strings_$add (lmd.data_class_string_ptr, "1"b, P_string);
	return;



log_match_$add_exclude_data_class:
     entry (P_lmd_ptr, P_string);

	call get_caller_lmd ();
	call match_strings_$add (lmd.data_class_string_ptr, "0"b, P_string);
	return;



log_match_$add_match_data:
     entry (P_lmd_ptr, P_string);

	call get_caller_lmd ();
	call match_strings_$add (lmd.data_string_ptr, "1"b, P_string);
	return;



log_match_$add_exclude_data:
     entry (P_lmd_ptr, P_string);

	call get_caller_lmd ();
	call match_strings_$add (lmd.data_string_ptr, "0"b, P_string);
	return;



log_match_$add_severity:
     entry (P_lmd_ptr, P_min_severity, P_max_severity);

	call get_caller_lmd ();
	if (P_min_severity > P_max_severity) then
	     min_severity = max (lbound (lmd.severity, 1), P_max_severity);
	else min_severity = max (lbound (lmd.severity, 1), P_min_severity);
	if (P_min_severity > P_max_severity) then
	     max_severity = min (hbound (lmd.severity, 1), P_min_severity);
	else max_severity = min (hbound (lmd.severity, 1), P_max_severity);

	lmd.select_severity = "1"b;
	do severity_idx = min_severity to max_severity;
	     lmd.severity (severity_idx) = "1"b;
	     end;
	return;

/* */

log_match_$clear_severity:
     entry (P_lmd_ptr);

	if (P_lmd_ptr = null ()) then return;
	call get_caller_lmd ();
	lmd.select_severity = "0"b;
	string (lmd.severity) = ""b;
	return;



log_match_$clear_text_strings:
     entry (P_lmd_ptr);

	if P_lmd_ptr = null ()
	then return;
	call get_caller_lmd ();
	call match_strings_$free (lmd.text_string_ptr);
	return;

log_match_$clear_data_class_strings:
     entry (P_lmd_ptr);

	if P_lmd_ptr = null ()
	then return;
	call get_caller_lmd ();
	call match_strings_$free (lmd.data_class_string_ptr);
	return;



log_match_$clear_data_strings:
     entry (P_lmd_ptr);

	if P_lmd_ptr = null ()
	then return;
	call get_caller_lmd ();
	call match_strings_$free (lmd.data_string_ptr);
	return;


log_match_$print:
     entry (P_lmd_ptr, P_IOCB_ptr, P_indent);

	if P_lmd_ptr = null ()
	then return;
	call get_caller_lmd ();
	if lmd.select_severity
	then call print_severity;
	call match_strings_$print (P_IOCB_ptr, P_indent, "Text", lmd.text_string_ptr);
	call match_strings_$print (P_IOCB_ptr, P_indent, "Data class", lmd.data_class_string_ptr);
	call match_strings_$print (P_IOCB_ptr, P_indent, "Data", lmd.data_string_ptr);
	return;


/* */

get_caller_lmd:
     procedure ();

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


	lmd_ptr = P_lmd_ptr;

	if (lmd_ptr ^= null ()) then return;

	system_area_ptr = get_system_free_area_ ();
	allocate lmd in (system_area) set (lmd_ptr);

	unspec (lmd) = ""b;
	lmd.text_string_ptr = null ();
	lmd.data_string_ptr = null ();
	lmd.data_class_string_ptr = null ();
	lmd.area_ptr = system_area_ptr;
	P_lmd_ptr = lmd_ptr;			/* Give it back to our caller */

	return;
	end get_caller_lmd;

print_severity:
	procedure options (non_quick);

/**** This program has the unenviable task of turning that bitstring
      into a set of ranges. */

declare ranges_used fixed bin;
declare ranges (512) char (32) unaligned;
declare used_ranges (ranges_used) char (32) unaligned based;

declare last_on_index fixed bin;
declare current_index fixed bin;

	ranges_used = 0;
	unspec (ranges)  = ""b;
	last_on_index = -10000;
	do current_index = lbound (lmd.severity, 1) to hbound (lmd.severity, 1);
	     if last_on_index < lbound (lmd.severity, 1)
	     then if lmd.severity (current_index)
		then last_on_index = current_index;
		else ; /* no pending range, none starts here */
	     else if lmd.severity (current_index)
		then ; /* range continues through here */
		else do; /* terminate a range */
		     ranges_used = ranges_used + 1;
		     call ioa_$rsnnl ("^d^[ to ^d^]", ranges (ranges_used), (0), last_on_index, last_on_index ^= (current_index - 1), current_index - 1);
		     last_on_index = -10000;
		end;
	     end; /* done the loop */
	if ranges_used = 0 then return; /* nothing to say */
	call ioa_$ioa_switch (P_IOCB_ptr, "^vx Severities: ^(^a ^)", P_indent,
	     addr (ranges) -> used_ranges (*));
	return;

	end print_severity;

%page; %include log_message;

	end log_match_;




		    log_output_.pl1                 01/17/85  0841.8rew 01/17/85  0834.6       83520



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* attach/detach/open/close for the log_output_ io module */

/* format: style2 */

/**** Written 1984-10 BIM */
/**** Modified 1984-10-22 BIM for control orders */

log_output_$log_output_attach:
     procedure (IOCB_ptr, Options, Com_err_sw, Code);

	declare (
	        IOCB_ptr		 pointer,
	        Options		 dimension (*) character (*) varying,
	        Com_err_sw		 bit (1) aligned,
	        Code		 fixed bin (35),
	        Reserved		 bit (1) aligned,
	        Mode		 fixed bin
	        )			 parameter;

%page;
%include log_output_attach_data_;
%page;
%include iocb;
%page;
%include iox_modes;
%include iox_entries;
%include area_info;
%page;

	declare cleanup_proc	 entry variable;
	declare code		 fixed bin (35);
	declare iocb_ptr		 pointer;
	declare saved_mask		 bit (36) aligned;
	declare 1 IOCB		 aligned like iocb based (iocb_ptr);

	declare define_area_	 entry (pointer, fixed binary (35));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare release_area_	 entry (pointer);

	declare (
	        hcs_$set_ips_mask,
	        hcs_$reset_ips_mask
	        )			 entry (bit (36) aligned, bit (36) aligned);


	declare (
	        log_output_io_$modes,
	        log_output_io_$control,
	        log_output_io_$put_chars
	        )			 entry external;
	declare log_output_io_$flush_pending_output
				 entry (pointer, fixed binary (35));
	declare log_write_$open	 entry (character (*), character (*), bit (1) aligned, pointer, fixed binary (35))
				 ;
	declare log_write_$close	 entry (pointer, fixed binary (35));

	declare sys_info$max_seg_size	 fixed bin (35) ext static;
	declare (
	        error_table_$badopt,
	        error_table_$bad_mode,
	        error_table_$improper_data_format,
	        error_table_$too_many_args,
	        error_table_$not_detached,
	        error_table_$noentry
	        )			 fixed bin (35) external static;

	declare cleanup		 condition;
	declare ME		 character (32) init ("log_output_") internal static options (constant);

/* attach entrypoint */

	if IOCB_ptr -> iocb.attach_descrip_ptr ^= null ()
	then do;
		Code = error_table_$not_detached;
		return;
	     end;
	attach_data_ptr = null ();
	on cleanup call cleanup_attach;
	call setup_attach;
	call parse_atd;				/* creates an attach data structure */
	call define_buffer_area;
	call attach_switch;				/* connects up iocb */
	return;

lo_detach:
     entry (IOCB_ptr, Code);
	call setup;				/* actual_iocb_ptr */
	IOCB.attach_descrip_ptr = null ();
	call release_area_ (attach_data.buffer_area_ptr);
	free attach_data;
	call propagate;
	go to return_;

lo_close:
     entry (IOCB_ptr, Code);
	call setup;

	call log_output_io_$flush_pending_output (addr (attach_data), (0));
	call log_write_$close (attach_data.log_info_ptr, (0));
	call mask;
	IOCB.open = lo_open;
	IOCB.detach_iocb = lo_detach;
	IOCB.modes = iox_$err_not_open;
	IOCB.control = iox_$err_not_open;
	IOCB.open_descrip_ptr = null ();
	call unmask;
	call propagate;

	go to return_;



lo_open:
     entry (IOCB_ptr, Mode, Reserved, Code);

	call setup;				/* get actual_iocb_ptr, et al */

	if Mode = Stream_output
	then do;
		attach_data.open_mode = Stream_output;	/* compiler should be cleverer with constant */
		attach_data.open_description = iox_modes (Stream_output);
		call init_modes;

	     end;
	else do;
		code = error_table_$bad_mode;
		go to return_;
	     end;

	on cleanup call cleanup_open;
	cleanup_proc = cleanup_open;			/* for the benefit of return_ */

	call log_write_$open (attach_data.dir_name, attach_data.entryname, (attach_data.create_ok),
	     attach_data.log_info_ptr, code);
	if code ^= 0
	then go to return_;				/* not according to log_mgr_ contract */

	call mask;
	IOCB.open_descrip_ptr = addr (attach_data.open_description);
	IOCB.put_chars = log_output_io_$put_chars;
	IOCB.modes = log_output_io_$modes;
	IOCB.control = log_output_io_$control;
	IOCB.close = lo_close;
	call unmask;
	call propagate;
	cleanup_proc = nulle;			/* we do not want to clean up */
	go to return_;

return_:
	call cleanup_proc;
	Code = code;
	return;


setup_attach:
     procedure;

	declare get_system_free_area_	 entry () returns (ptr);
	declare system_free_area	 area (1024 /*irrelevant*/) based (get_system_free_area_ ());

	iocb_ptr = IOCB_ptr;			/* not actual iocb ptr for the attact entrypoint */
	cleanup_proc = cleanup_attach;		/* return_ will call this */

	allocate attach_data in (system_free_area) set (attach_data_ptr);
	attach_data.buffer_area_ptr = null ();		/* window here, if we cleanup before this is executed */
	attach_data.open_mode = 0;
	attach_data.log_info_ptr = null ();
	string (attach_data.flags) = ""b;
	attach_data.binary_data_class = "";
	attach_data.binary_data_ptr = null ();
	attach_data.binary_data_length = 0;
	attach_data.dir_name, attach_data.entryname = "";
	attach_data.attach_description, attach_data.open_description = "";
	attach_data.buffer_chain.head = null ();
	attach_data.buffer_chain.tail = null ();
	attach_data.create_ok = "1"b;			/* on by default */
	code = 0;
     end setup_attach;


parse_atd:
     procedure;

	declare current_option	 fixed bin;
	declare last_option		 fixed bin;
	declare option_length	 fixed bin (21);

	current_option = lbound (Options, 1);
	last_option = hbound (Options, 1);
	option_length = maxlength (Options (1));	/* same answer for all of them */
	if last_option = 0
	then call attach_error (0, "Usage: log_output_ LOG_PATHNAME {-control_args}");
						/* it does not return */
	do while (current_option <= last_option);
	     begin;
		declare option		 character (option_length) varying defined (Options (current_option));
		declare next_option		 character (option_length) varying
					 defined (Options (current_option + 1));

		if index (option, "-") ^= 1
		then do;				/* not a control argument */
			if attach_data.entryname ^= ""
			then call attach_error (error_table_$too_many_args, "Only one pathname may be given.");
			call expand_pathname_ ((option), attach_data.dir_name, attach_data.entryname, code);
			if code ^= 0
			then call attach_error (code, (option));
		     end;				/* pathname taken care of */
		else do;				/* control argument */
			if option = "-create"
			then attach_data.create_ok = "1"b;
			else if option = "-no_create"
			then attach_data.create_ok = "0"b;
			else call attach_error (error_table_$badopt, (option));
		     end;
	     end;
	     current_option = current_option + 1;
	end;
	/*** The atd is now parse'd. so much for this */

	attach_data.attach_description =
	     rtrim (ME) || " " || rtrim (attach_data.dir_name) || ">" || rtrim (attach_data.entryname);
	if attach_data.create_ok
	then attach_data.attach_description = attach_data.attach_description || " -create";
	else attach_data.attach_description = attach_data.attach_description || " -no_create";

     end parse_atd;


attach_switch:
     procedure;

	call mask;
	IOCB.open = lo_open;
	IOCB.detach_iocb = lo_detach;
	IOCB.attach_data_ptr = attach_data_ptr;
	IOCB.attach_descrip_ptr = addr (attach_data.attach_description);
	call unmask;
	call propagate;
     end attach_switch;


setup:
     procedure;

	cleanup_proc = nulle;
	iocb_ptr = IOCB_ptr -> iocb.actual_iocb_ptr;
	code = 0;
	attach_data_ptr = IOCB.attach_data_ptr;
	saved_mask = ""b;
     end setup;

mask:
     procedure;
	call hcs_$set_ips_mask (""b, saved_mask);
	return;

unmask:
     entry;
	call hcs_$reset_ips_mask (saved_mask, saved_mask);
	return;
     end mask;

propagate:
     procedure;
	call iox_$propagate (iocb_ptr);
     end propagate;

cleanup_open:
     procedure;
	if attach_data.log_info_ptr ^= null ()
	then call log_write_$close (attach_data.log_info_ptr, (0));
     end cleanup_open;

cleanup_attach:
     procedure;
	if attach_data_ptr ^= null ()
	then do;
		if unspec (attach_data.buffer_area_ptr) ^= ""b & attach_data.buffer_area_ptr ^= null
		then call release_area_ (attach_data.buffer_area_ptr);
		free attach_data;
	     end;
     end cleanup_attach;


attach_error:
     procedure (code, reason);

	declare code		 fixed bin (35);
	declare reason		 character (*);

	declare com_err_		 entry () options (variable);
	declare sub_err_		 entry () options (variable);

	if Com_err_sw
	then call com_err_ (code, ME, "^a.", reason);
	else call sub_err_ (code, "Log output attach", "h", null (), (0), "^a", reason);
	go to return_;
     end attach_error;

init_modes:
     procedure;

	attach_data.mode_string = "severity=0.";

     end init_modes;

nulle:
     procedure;
     end nulle;

define_buffer_area:
     procedure;

	declare 1 AI		 aligned like area_info;

	unspec (AI) = ""b;
	AI.version = area_info_version_1;
	AI.owner = "log_output_ buffers";
	AI.size = sys_info$max_seg_size;
	AI.areap = null ();
	AI.control.extend = "1"b;
	call define_area_ (addr (AI), code);
	if code ^= 0
	then call attach_error (code, "Failed to define buffer area.");
	attach_data.buffer_area_ptr = AI.areap;
	return;
     end define_buffer_area;


     end log_output_$log_output_attach;





		    log_output_io_.pl1              04/11/85  1354.1rew 04/11/85  0957.3      118548



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* log_output_io_.pl1 put_chars for log_output_ */
/* format: style2 */

/**** Created 1984-10 BIM */
/**** Modified 1984-10-22 BIM for get/set_binary_info */
/**** Modified 1984-10-31 BIM for flush_pending_output */
/**** Modified 1984-11-15 BIM to put back bugfix to buffer filling 
      when there is a newline in the middle of output. */
/**** Modified 1985-01-02, BIM: fixed partial line processing. */
/**** Modified 1985-02-10, BIM: another fix: load_buffer_chain to initialize loop control correctly */
/**** Modified 1985-03-25, EJ Sharpe: set return code on control entrypoint,
      add flush_pending_output as io_call control */

log_output_io_:
     procedure;

%page;
%include log_output_attach_data_;
%include log_output_binary_info;
%page;
%include mode_string_info;
%include dump_segment_format;
%page;
%include iocb;
%include io_call_info;
%page;


	declare (
	        Attach_data_ptr	 pointer,
	        IOCB_ptr		 pointer,
	        Buffer_ptr		 pointer,
	        Buffer_length	 fixed bin (21),
	        Info_ptr		 pointer,
	        Order_name		 char (*),
	        Code		 fixed bin (35),
	        (New_modes, Old_modes) character (*)
	        )			 parameter;

	declare buffer_string	 char (Buffer_length) based (Buffer_ptr);
	declare based_pointer	 pointer based;
	declare iocb_ptr		 pointer;
	declare 1 IOCB		 aligned like iocb based (iocb_ptr);
	declare 1 binary_info	 aligned like log_output_binary_info;
	declare code		 fixed bin (35);
	declare dump_segment_	 entry (pointer, pointer, fixed binary, fixed binary (18), fixed binary (18),
				 bit (*));
	declare log_write_$data	 entry (pointer, fixed binary, character (*), pointer, fixed binary,
				 character (16) var, pointer, fixed binary (35));
	declare log_write_$message	 entry (pointer, fixed binary, character (*), pointer, fixed binary (35));

%include iox_entries;

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

	declare addcharno		 builtin;
	declare addr		 builtin;
	declare addwordno		 builtin;
	declare byte		 builtin;
	declare divide		 builtin;
	declare hbound		 builtin;
	declare index		 builtin;
	declare length		 builtin;
	declare null		 builtin;
	declare substr		 builtin;


put_chars:
     entry (IOCB_ptr, Buffer_ptr, Buffer_length, Code);
	call setup;

	call process_lines;
	go to return_;

flush_pending_output:
     entry (Attach_data_ptr, Code);

	attach_data_ptr = Attach_data_ptr;
	if attach_data.buffer_chain.head = null ()
	then return;

	call process_lines$$flush;
	go to return_;


modes:
     entry (IOCB_ptr, New_modes, Old_modes, Code);
	call setup;

	begin options (non_quick);			/* dont buy this stack frame for put_chars */

	     declare old_msi_ptr	      pointer;
	     declare temp_string	      character (64);
	     declare i		      fixed bin;
	     declare mode_string_$parse     entry (char (*), ptr, ptr, fixed bin (35));
	     declare mode_string_$get	      entry (ptr, char (*), fixed bin (35));
	     declare mode_string_$combine   entry (ptr, ptr, char (*), fixed bin (35));
	     declare get_system_free_area_  entry () returns (ptr);
	     declare (
		   error_table_$bad_mode_value,
		   error_table_$bad_mode
		   )		      fixed bin (35) external static;

	     Old_modes = attach_data.mode_string;	/* left around from the last time */

	     call mode_string_$parse (New_modes, get_system_free_area_ (), mode_string_info_ptr, code);
	     if code ^= 0
	     then go to return_;

	     do i = 1 to hbound (mode_string_info.modes, 1);
		begin;
		     declare 1 MV		      aligned like mode_value defined (mode_string_info.modes (i));
		     if MV.mode_name = "severity"
		     then do;
			     if ^MV.numeric_valuep
			     then do;
				     code = error_table_$bad_mode_value;
				     go to return_;
				end;
			     attach_data.severity = MV.numeric_value;
			end;
		     else do;
			     code = error_table_$bad_mode;
			     go to return_;
			end;
		end;
	     end;
	     call mode_string_$parse ((attach_data.mode_string), get_system_free_area_ (), old_msi_ptr, (0));
						/* cant be an error, if so, null ptr */
	     call mode_string_$combine (old_msi_ptr, mode_string_info_ptr, temp_string, code);
	     if old_msi_ptr ^= null ()
	     then free old_msi_ptr -> mode_string_info;
	     free mode_string_info_ptr -> mode_string_info;
	     attach_data.mode_string = temp_string;
	     code = 0;
	     go to return_;
	end;					/* the begin block */
	go to return_;


control:
     entry (IOCB_ptr, Order_name, Info_ptr, Code);

	call setup;
	if Order_name = "get_binary_info"
	then call get_binary_info;
	else if Order_name = "set_binary_info"
	then call set_binary_info;
	else if Order_name = "io_call"
	then call io_call;
	else if Order_name = "get_log_write_data_ptr"
	then do;
		call check_non_null;
		Info_ptr -> based_pointer = attach_data.log_info_ptr;
	     end;
	else if Order_name = "flush_pending_output"
	then call process_lines$$flush;
	else code = error_table_$undefined_order_request;

	goto return_;


return_:
	Code = code;
	return;

setup:
     procedure;
	iocb_ptr = IOCB_ptr -> iocb.actual_iocb_ptr;
	attach_data_ptr = IOCB.attach_data_ptr;
	code = 0;
     end setup;

process_lines:
     procedure;

	declare nl_index		 fixed bin (21);
	declare cp		 pointer;
	declare cl		 fixed bin (21);
	declare caller_chars	 char (cl) based (cp);

	cp = addr (buffer_string);
	cl = length (buffer_string);


	nl_index = index (caller_chars, byte (10));	/* where is the first, (if any) newline ? */
	do while (nl_index > 0);			/* this iterates here when we have written the buffer and the first NL in the new string, and there is another. */
	     if attach_data.buffer_chain.head = null ()
	     then do while (nl_index > 0);
		     call write_line (cp, nl_index - 1);/* zero is ok here */
						/* drop the NL */
		     if nl_index = length (caller_chars)
		     then return;			/* all done */
		     cp = addcharno (cp, nl_index);
		     cl = cl - nl_index;		/* skip past newline */
		     nl_index = index (caller_chars, byte (10));
						/* exit when this finds none */
		end;

	     /*** We can punt if there is no newline here at all. */

	     if nl_index = 0			/* we had no new line at all, or caller fell out of loop with leftovers */
	     /*** no newlines at all. Add to the chain */
	     then do;
		     call add_buffer (cp, cl);	/* caller_chars, whats left of them */
		     return;
		end;

	     /*** There is a newline here, but there is pending information. 
	     We must load up all the buffered data into a buffer. */

	     buffer_length = attach_data.total_buffered_length + nl_index - 1;

	     /*** check for overlength here */

	     allocate buffer in (buffer_area);
	     buffer.next = null ();
	     call load_buffer_chain_into_buffer (buffer_ptr);

/**** pick up first line of new text */

	     if nl_index > 1
	     then substr (buffer.data, buffer.length - (nl_index - 2), nl_index - 1) =
		     substr (caller_chars, 1, nl_index - 1);
						/* If there were a char anf an NL, the one char goes at the last char of the buffer. NL index in that case is 2 */
	     call write_line (addr (buffer.data), buffer.length);
	     free buffer;				/* all gone */

	     if nl_index = length (caller_chars)	/* all used */
	     then return;				/* exit loop without further work */

	     cp = addcharno (cp, nl_index);
	     cl = cl - nl_index;
	     nl_index = index (caller_chars, byte (10));
	end;

	/*** We still have a tail to get rid of. */

	call add_buffer (cp, cl);			/* buffer remainder */
	return;


process_lines$$flush:
     entry;

	buffer_length = attach_data.total_buffered_length;
	if buffer_length = 0
	then return;
	allocate buffer;
	buffer.next = null ();
	call load_buffer_chain_into_buffer (buffer_ptr);
	call write_line (addr (buffer.data), buffer.length);
	free buffer;
	return;

add_buffer:
     procedure (dp, dl);

	declare dp		 pointer;
	declare dl		 fixed bin (21);
	declare data		 char (dl) based (dp);

	if dl = 0
	then return;
	buffer_length = dl;
	attach_data.total_buffered_length = attach_data.total_buffered_length + dl;
	allocate buffer in (buffer_area);
	buffer.data = data;
	buffer.next = null ();
	if attach_data.buffer_chain.tail ^= null ()
	then attach_data.buffer_chain.tail -> buffer.next = addr (buffer);
	attach_data.buffer_chain.tail = addr (buffer);
	if attach_data.buffer_chain.head = null ()
	then attach_data.buffer_chain.head = addr (buffer);
	return;
     end add_buffer;

load_buffer_chain_into_buffer:
     procedure (target_bp);

	declare target_bp		 pointer;
	declare cx		 fixed bin;
	declare tbp		 pointer;
	declare bp		 pointer;
	declare nbp		 pointer;

	cx = 1;
	tbp = target_bp;
	nbp = attach_data.buffer_chain.head;		/* THIS SIMULATES "do until", guaranteeing one trip through loop if there is anthing in the chain */
	do bp = attach_data.buffer_chain.head repeat nbp while (nbp ^= null ());
	     nbp = bp -> buffer.next;			/* we will free */
	     substr (tbp -> buffer.data, cx, bp -> buffer.length) = bp -> buffer.data;
	     cx = cx + bp -> buffer.length;
	     free bp -> buffer;

	end;
	attach_data.total_buffered_length = 0;		/* all gone */
	attach_data.buffer_chain.head, attach_data.buffer_chain.tail = null ();
	return;
     end load_buffer_chain_into_buffer;

write_line:
     procedure (dp, dl);

	declare dp		 pointer;
	declare dl		 fixed bin (21);

	declare line		 char (dl) based (dp);

	if attach_data.binary_data
	then call log_write_$data (attach_data.log_info_ptr, attach_data.severity, line, attach_data.binary_data_ptr,
		(attach_data.binary_data_length), attach_data.binary_data_class, (null ()), code);
	else call log_write_$message (attach_data.log_info_ptr, attach_data.severity, line, (null ()), code);
	return;
     end write_line;
     end process_lines;

get_binary_info:
     procedure;

	call check_non_null;
	log_output_binary_info_ptr = Info_ptr;
	if log_output_binary_info.version ^= LOG_OUTPUT_BINARY_INFO_VERSION_1
	then do;
		code = error_table_$unimplemented_version;
		go to return_;
	     end;

	log_output_binary_info.data_class = attach_data.binary_data_class;
	log_output_binary_info.data_ptr = attach_data.binary_data_ptr;
	log_output_binary_info.data_length = attach_data.binary_data_length;
	return;
     end get_binary_info;

set_binary_info:
     procedure;

	call check_non_null;
	log_output_binary_info_ptr = Info_ptr;
	if log_output_binary_info.version ^= LOG_OUTPUT_BINARY_INFO_VERSION_1
	then do;
		code = error_table_$unimplemented_version;
		go to return_;
	     end;

	if attach_data.binary_data_ptr ^= null
	then free binary_data;
	attach_data.binary_data_class = "";
	attach_data.binary_data_ptr = null ();
	attach_data.binary_data = "0"b;
	if log_output_binary_info.data_class = ""
	then return;
	attach_data.binary_data = "1"b;
	attach_data.binary_data_length = log_output_binary_info.data_length;
	allocate binary_data in (buffer_area) set (attach_data.binary_data_ptr);
	attach_data.binary_data_class = log_output_binary_info.data_class;
	binary_data = log_output_binary_info.data_ptr -> binary_data;
	return;
     end set_binary_info;

io_call:
     procedure;

	call check_non_null;
	io_call_infop = Info_ptr;

	if io_call_info.order_name = "flush_pending_output"
	then call process_lines$$flush;
	else if io_call_info.order_name = "get_binary_info"
	then do;
		if attach_data.binary_data
		then do;
			call io_call_info.report ("Data class ^a", attach_data.binary_data_class);
			dump_segment_format_structure = "0"b;
			dump_segment_format_structure.offset = "1"b;
			dump_segment_format_structure.ascii = "1"b;
			dump_segment_format_structure.octal = "1"b;
			dump_segment_format_structure.raw_data = "1"b;
			dump_segment_format_structure.interpreted_data = "1"b;
			dump_segment_format_structure.suppress_duplicates = "1"b;

			call dump_segment_ (iox_$user_output, attach_data.binary_data_ptr, 0, 0,
			     attach_data.binary_data_length, dump_segment_format);
		     end;
		else call io_call_info.report ("No binary info.");
	     end;
	else if io_call_info.order_name = "set_binary_info"
	then do;
		binary_info.version = LOG_OUTPUT_BINARY_INFO_VERSION_1;
		if io_call_info.args (1) = "-none"
		then binary_info.data_class = "";
		else do;
			binary_info.data_class = io_call_info.args (1);
			binary_info.data_ptr = addwordno (addr (io_call_info.args (2)), 1);
			binary_info.data_length = divide (length (io_call_info.args (2)), 4, 21, 0);
			call iox_$control (iocb_ptr, "set_binary_info", addr (binary_info), code);
		     end;
	     end;
	else code = error_table_$undefined_order_request;
	go to return_;
     end io_call;

check_non_null:
     procedure;

	if Info_ptr = null ()
	then do;
		code = error_table_$null_info_ptr;
		go to return_;
	     end;
	return;
     end check_non_null;

     end log_output_io_;




		    match_strings_.pl1              05/03/85  0823.7rew 05/03/85  0807.2      131733



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

/* *	MATCH_STRINGS_
   *
   *	This is a general-purpose utility procedure for matching a string
   *	against some set of previously supplied -match or -exclude strings.
   *	It detects regular expressions automatically by the surrounding slash
   *	delimiters and handles them by calling search_file_.
   *
   *	Created for new print_sys_log, 84-06-10, W. Olin Sibert
   *	Modified 1984-10-24 BIM for $print, fixed end processing.
   *      Modified 1984-11-30 BIM for indent in $print.
   *	Modified 1985-05-01 Steve Herbst to initialize match_info.string_info (i) to zero.
*/

	declare P_IOCB_ptr		 pointer;
	declare P_indent		 fixed bin;
	declare P_match_info_ptr	 pointer parameter;
	declare P_match_string	 char (*) parameter;
	declare P_match_sw		 bit (1) aligned parameter;
	declare P_tested_string	 char (*) parameter;
	declare P_title		 char (*) parameter;

	declare match_info_ptr	 pointer;
	declare match_info_max_strings fixed bin;
	declare match_info_area	 area based (match_info.area_ptr);

	declare match_string_ptr	 pointer;
	declare match_string_lth	 fixed bin (21);
	declare match_string	 char (match_string_lth) based (match_string_ptr);

	declare 1 match_info	 aligned based (match_info_ptr),
		2 header		 aligned,
		  3 area_ptr	 pointer,
		  3 max_strings	 fixed bin,
		  3 n_strings	 fixed bin,
		2 string_info	 (match_info_max_strings refer (match_info.max_strings)),
		  3 string_ptr	 pointer unaligned,
		  3 string_lth	 fixed bin (21),
		  3 flags		 aligned,
		    4 exclude_sw	 bit (1) unaligned,
		    4 begin_sw	 bit (1) unaligned,
		    4 end_sw	 bit (1) unaligned,
		    4 regexp_sw	 bit (1) unaligned,
		    4 pad		 bit (32) unaligned,
		2 end		 fixed bin;

	declare tested_string_ptr	 pointer;
	declare tested_string_lth	 fixed bin (21);
	declare tested_string	 char (tested_string_lth) based (tested_string_ptr);

	declare get_system_free_area_	 entry () returns (pointer);
	declare ioa_$ioa_switch	 entry () options (variable);


	declare DEFAULT_SIZE	 fixed bin internal static options (constant) init (10);
	declare REGEXP_CHARS	 char (3) internal static options (constant) init ("\.*");
	declare REGEXP_SLASH	 char (1) internal static options (constant) init ("/");
	declare BEGIN_CHAR		 char (1) internal static options (constant) init ("^");
	declare END_CHAR		 char (1) internal static options (constant) init ("$");

	declare (addcharno, addr, index, length, null, substr, unspec, verify)
				 builtin;

/**/

match_strings_$test:
     entry (P_match_info_ptr, P_tested_string) returns (bit (1) aligned);

	match_info_ptr = P_match_info_ptr;
	tested_string_ptr = addr (P_tested_string);
	tested_string_lth = length (P_tested_string);

	if (match_info_ptr = null ())
	then return ("1"b);
	if (match_info.n_strings = 0)
	then return ("1"b);

	return (do_match ());



match_strings_$add:
     entry (P_match_info_ptr, P_match_sw, P_match_string);

	match_info_ptr = P_match_info_ptr;
	match_string_ptr = addr (P_match_string);
	match_string_lth = length (P_match_string);

	call add_string (P_match_sw, "0"b);

	P_match_info_ptr = match_info_ptr;		/* In case it changed */
	return;

match_strings_$add_literal:				/* force exact match of test without regexp's */
     entry (P_match_info_ptr, P_match_sw, P_match_string);

	match_info_ptr = P_match_info_ptr;
	match_string_ptr = addr (P_match_string);
	match_string_lth = length (P_match_string);

	call add_string (P_match_sw, "1"b);

	P_match_info_ptr = match_info_ptr;		/* In case it changed */
	return;


match_strings_$free:
     entry (P_match_info_ptr);

	match_info_ptr = P_match_info_ptr;
	P_match_info_ptr = null ();

	call free_match_info ();

	return;

match_strings_$print:
     entry (P_IOCB_ptr, P_indent, P_title, P_match_info_ptr);

	match_info_ptr = P_match_info_ptr;
	if match_info_ptr = null ()
	then return;

	call print_strings;
	return;

/**/

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

	declare match_idx		 fixed bin;
	declare match_result	 bit (1) aligned;
	declare final_result	 bit (1) aligned;


/* If the first argument was -exclude, then the result is ALL strings except
   those excluded.	Contrariwise, if the first argument was -match, then the
   result is NO strings except those matching.  So, we start out by setting
   the final result to the first exclude_sw value. */

	final_result = match_info.exclude_sw (1);

/* Version 2 selector:  Consider each match string in turn.	 If the string
   followed -match, and the message matches it, then set the result to true.
   If the string followed -exclude, and the message matches it, then set the
   result to false.	 Otherwise, leave the result alone.

   This is simpler than version 1, which was simply ridiculous. Gary Dixon
   has a more complicated version that I don't understand how to implement
   or describe, but which may be better (New_Log_primitives [0146]).
*/

	do match_idx = 1 to match_info.n_strings;
	     match_result = try_match ();

	     if match_result
	     then if match_info.exclude_sw (match_idx)
		then final_result = "0"b;
		else final_result = "1"b;
	end;

	return (final_result);

/**/

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

	declare match_string_ptr	 pointer;
	declare match_string_lth	 fixed bin (21);
	declare match_string	 char (match_string_lth) based (match_string_ptr);

/* This procedure applies tests according to the various flags in the match_info
   structure. It returns immediately when it knows it has a match failure, but
   otherwise falls through to the end where it indicates success. It is then
   the caller's job to interpret the exclude_sw properly. */


	match_string_ptr = match_info.string_ptr (match_idx);
	match_string_lth = match_info.string_lth (match_idx);

	if match_info.regexp_sw (match_idx)
	then return (try_regexp_match ());

	if (match_info.begin_sw (match_idx)) & (match_info.end_sw (match_idx))
	then do;
		if (match_string_lth ^= tested_string_lth)
		then return ("0"b);
		if (match_string ^= tested_string)
		then return ("0"b);
		return ("1"b);
	     end;

	if (match_info.begin_sw (match_idx))
	then do;
		if (match_string_lth > tested_string_lth)
		then return ("0"b);
		if (substr (tested_string, 1, match_string_lth) ^= match_string)
		then return ("0"b);
		if ^match_info.end_sw (match_idx)
		then return ("1"b);			/* passes all available tests */
	     end;

	if (match_info.end_sw (match_idx))
	then do;
		if (match_string_lth > tested_string_lth)
		then return ("0"b);
		if (substr (tested_string, (tested_string_lth - match_string_lth + 1)) ^= match_string)
		then return ("0"b);
		return ("1"b);			/* begin tested, end passes */
	     end;

/**** Here iff there is no ^ or $ or difficult regexp */

	if (match_string_lth > tested_string_lth)
	then return ("0"b);

	if (index (tested_string, match_string) = 0)
	then return ("0"b);

	return ("1"b);

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

	declare search_file_$silent	 entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21),
				 fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (35));
	declare sf_code		 fixed bin (35);
	declare must_fake_NL	 bit (1) aligned;

	must_fake_NL = "0"b;
	if substr (match_string, match_string_lth, 1) = END_CHAR
	then if match_string_lth < 3
	     then must_fake_NL = "1"b;
	     else if substr (match_string, match_string_lth - 2, 3) ^= "\c$"
	     then must_fake_NL = "1"b;

	if ^must_fake_NL
	then call search_file_$silent (match_string_ptr, 1, match_string_lth, addr (tested_string), 1,
		tested_string_lth, (0), (0), sf_code);
	else begin;
		declare longer_tested_string	 char (tested_string_lth + 1);
		longer_tested_string = tested_string || byte (10);
		call search_file_$silent (match_string_ptr, 1, match_string_lth, addr (longer_tested_string), 1,
		     tested_string_lth + 1, (0), (0), sf_code);
	     end;
	return (sf_code = 0);
     end try_regexp_match;
     end try_match;

     end do_match;

/**/

add_string:
     procedure (P_match_sw, P_literal_sw);


	declare P_match_sw		 bit (1) aligned parameter;
	declare P_literal_sw	 bit (1) aligned parameter;
	declare new_idx		 fixed bin;
	declare new_string_ptr	 pointer;
	declare new_string_lth	 fixed bin (21);
	declare new_string		 char (new_string_lth) based (new_string_ptr);


	if (match_info_ptr = null ())
	then call reallocate_match_info (DEFAULT_SIZE);

	else if (match_info.n_strings >= match_info.max_strings)
	then call reallocate_match_info (match_info.n_strings + DEFAULT_SIZE);

	new_idx = match_info.n_strings + 1;		/* Use the next entry */
	unspec (match_info.flags (new_idx)) = "0"b;
	match_info.exclude_sw (new_idx) = ^P_match_sw;


/* For string matching, there are three flags:

   1) regexp_sw -- when this is set, search_file_ is called for this string
   each message. Regular expressions are signalled by slashes surrounding
   the string. Since search_file_ is rather expensive, however, the string
   is examined to see whether it is a trivial regular expression, involving
   only the begin ("^") or end ("$") character, in which case, regexp_sw
   is turned off, and one or both of the following two are turned on:
   2) begin_sw -- when set, indicates that the message must begin with this
   string to match.
   3) end_sw -- when set, indicates that the message must end with this string
   to match.

   Testing for these conditions is the purpose of the set of tests below. If
   the string is a regular expression, its start and length are adjusted to
   remove the slashes; similarly, if it is determined to be one of the two
   trivial cases, the leading/trailing regexp character must be removed.
   Note that detection of the trivial cases does not include cases where the
   only regexp characters are escaped with backslash-C; this didn't seem
   worth it, and, in fact, any string containing backslashes is considered
   non-trivial. */


	if ^P_literal_sw
	then if (length (match_string) > 2)
	     then /* See explanation above for details of this code */
		if (substr (match_string, 1, 1) = REGEXP_SLASH)
		then if (substr (match_string, length (match_string), 1) = REGEXP_SLASH)
		     then do;
			     match_string_ptr = addcharno (match_string_ptr, 1);
			     match_string_lth = match_string_lth - 2;
			     if (search (match_string, REGEXP_CHARS) = 0)
			     then do;		/* trivial regexp */
				     if (length (match_string) > 1)
				     then if (substr (match_string, 1, 1) = BEGIN_CHAR)
					then do;
						match_info.begin_sw (new_idx) = "1"b;
						match_string_lth = match_string_lth - 1;
						match_string_ptr = addcharno (match_string_ptr, 1);
					     end;

				     if (length (match_string) > 2)
				     then if (substr (match_string, length (match_string), 1) = END_CHAR)
					then do;
						match_info.end_sw (new_idx) = "1"b;
						match_string_lth = match_string_lth - 1;
					     end;
				end;		/* Of trivial regexp case */
			     else do;		/* non-trivial! */
				     match_info.regexp_sw (new_idx) = "1"b;

				     if (length (match_string) > 2)
				     then /* Test for trimming a trailing "$" */
					if (substr (match_string, length (match_string) - 1, 1) = END_CHAR)
					then match_string_lth = match_string_lth - 1;
				end;		/* of hard regexp case */
			end;			/* Of regexp case */

	new_string_lth = match_string_lth;		/* Now, allocate a copy for later use in matching */
	allocate new_string in (match_info_area) set (new_string_ptr);

	new_string = match_string;			/* Copy from our (adjusted) caller's string */

	match_info.string_ptr (new_idx) = new_string_ptr;
	match_info.string_lth (new_idx) = new_string_lth;
	if P_literal_sw
	then match_info.begin_sw (new_idx), match_info.end_sw (new_idx) = "1"b;
	match_info.n_strings = new_idx;		/* Adjust the count to include this one */

	return;
     end add_string;

/**/

reallocate_match_info:
     procedure (P_size);

	declare P_size		 fixed bin parameter;

	declare nmi_ptr		 pointer;
	declare old_size		 fixed bin;
	declare nmi_idx		 fixed bin;
	declare system_area_ptr	 pointer;
	declare system_area		 area based (system_area_ptr);


	match_info_max_strings = P_size;
	system_area_ptr = get_system_free_area_ ();

	if (match_info_ptr = null ())
	then old_size = 0;
	else old_size = match_info.n_strings;

	allocate match_info in (system_area) set (nmi_ptr);

	if (match_info_ptr ^= null ())
	then nmi_ptr -> match_info.header = match_info.header;
	else unspec (nmi_ptr -> match_info) = ""b;

	nmi_ptr -> match_info.max_strings = match_info_max_strings;
	nmi_ptr -> match_info.area_ptr = system_area_ptr;

	do nmi_idx = 1 to old_size;
	     nmi_ptr -> match_info.string_info (nmi_idx) = match_info.string_info (nmi_idx);
	end;

	do nmi_idx = (old_size + 1) to nmi_ptr -> match_info.max_strings;
	     unspec (nmi_ptr -> match_info.string_info (nmi_idx)) = "0"b;
	     nmi_ptr -> match_info.string_ptr (nmi_idx) = null ();
	end;

	if (match_info_ptr ^= null ())
	then free match_info in (system_area);

	match_info_ptr = nmi_ptr;
	return;
     end reallocate_match_info;

/**/

free_match_info:
     procedure ();

	declare mi_idx		 fixed bin;


	if (match_info_ptr = null ())
	then return;

	do mi_idx = 1 to match_info.n_strings;
	     match_string_ptr = match_info.string_ptr (mi_idx);
	     match_string_lth = match_info.string_lth (mi_idx);
	     free match_string in (match_info_area);
	end;

	free match_info in (match_info_area);
	match_info_ptr = null ();

	return;
     end free_match_info;

print_strings:
     procedure;

	declare sx		 fixed bin;
	declare 1 csi		 aligned like match_info.string_info based (csip);
	declare csip		 pointer;
	declare cstring		 char (csi.string_lth) based (csi.string_ptr);

	if match_info.header.n_strings = 0
	then return;
	call ioa_$ioa_switch (P_IOCB_ptr, "^vx^a match and exclude strings:", P_indent, P_title);
	do sx = 1 to match_info.n_strings;
	     csip = addr (match_info.string_info (sx));
	     call ioa_$ioa_switch (P_IOCB_ptr, "^vx  ^[match  ^;exclude^] ^[/^]^[^^^]^a^[$^]^[/^]", P_indent,
		^csi.flags.exclude_sw, csi.flags.regexp_sw | csi.flags.begin_sw | csi.flags.end_sw,
		csi.flags.begin_sw, cstring, csi.flags.end_sw,
		csi.flags.regexp_sw | csi.flags.begin_sw | csi.flags.end_sw);
	end;
	return;
     end print_strings;

     end match_strings_;




		    monitor_sys_log.pl1             11/03/86  1035.8r   11/03/86  0951.3      476775



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

/* format: style2,indcomtxt */
msl:
monitor_sys_log:
     procedure () options (variable);

/**** Modification History:
      Created 1984-11-29 BIM from print_sys_log.
      Modified 1984-12-26, BIM: Added -continuation_indent.
      Modified 1985-01-16, BIM: Added -match/exclude/all_data_class, -pid, -data_class.
      Modified 1985-01-25, BIM: fixed dm log name, other silly bugs.
      Modified 1985-02-07, Steve Herbst: Changed to call dm_misc_util_$get_log_path.
      Modified 1985-02-21, Steve Herbst: Fixed bug in -dms  */



/****^  HISTORY COMMENTS:
  1) change(86-04-29,Kissel), approve(86-07-31,MCR7456), audit(86-08-01,Wong),
     install(86-11-03,MR12.0-1149):
     Changed to support the DSA system logs using the -dsasl and -dsasal
     control arguments.
                                                   END HISTORY COMMENTS */


	declare an_entry_ptr	 pointer;
	declare 1 an_entry		 aligned like monitor_sys_log_array.entry based (an_entry_ptr);
	declare code		 fixed bin (35);
	declare dm_system_log_path	 char (168);
	declare dsa_system_log_path	 char (168);
	declare log_index		 fixed bin;
	declare log_dname		 char (168);
	declare log_ename		 char (32);
	declare 1 log_open_info	 aligned like log_read_open_info;
	declare sci_ptr		 pointer;
	declare old_mask		 bit (36) aligned;
	declare 1 opt1		 like opt based;	/* To catch unqualified references */

	declare 1 opt		 automatic aligned, /* Miscellaneous options for the command itself; */
		2 pathname	 char (168) unal,	/* note that formatting options are kept separately */
		2 pointers,			/* in the log_message_format structure */
		  3 log_read_ptr	 pointer,
		  3 expand_select_ptr
				 pointer,
		  3 lmd_ptr	 pointer,
		  3 iocb_ptr	 pointer,
		2 reader_procedure	 char (32) varying,
		2 iocb_name	 char (32) unaligned,
		2 call_command	 aligned,
		  3 ptr		 pointer,
		  3 length	 fixed bin (21),
		2 time		 fixed bin (71),
		2 log_number	 fixed bin,
		2 flags		 aligned,
		  3 the_syserr_log_sw
				 bit (1),
		  3 the_as_log_sw	 bit (1),
		  3 the_admin_log_sw bit (1),
		  3 the_dm_log_sw	 bit (1),
		  3 the_dsas_log_sw	 bit (1),
		  3 the_dsasa_log_sw bit (1),
		  3 all_sw	 bit (1),
		  3 expand_sw	 bit (1),
		  3 octal_sw	 bit (1),
		  3 interpret_sw	 bit (1),
		  3 add_sw	 bit (1),
		  3 remove_sw	 bit (1),
		  3 on_sw		 bit (1),
		  3 off_sw	 bit (1),
		  3 status_sw	 bit (1),
		  3 replace_sw	 bit (1),
		  3 modify_sw	 bit (1),
		  3 time_given_sw	 bit (1),
		  3 prefix_given_sw	 bit (1),
		  3 call_given_sw	 bit (1),
		  3 free_from_opt	 bit (1),		/* info in here should be freed */
		  3 process_id_sw	 bit (1),
		  3 data_class_sw	 bit (1);

	declare opt_call_command_string
				 char (opt.call_command.length) based (opt.call_command.ptr);

	declare iox_$user_output	 ptr ext static;
	declare error_table_$bad_arg	 fixed bin (35) ext static;
	declare error_table_$namedup	 fixed bin (35) ext static;
	declare error_table_$inconsistent
				 fixed bin (35) ext static;
	declare error_table_$name_not_found
				 fixed bin (35) ext static;
	declare error_table_$unexpected_condition
				 fixed bin (35) ext static;
	declare error_table_$badopt	 fixed bin (35) external static;
	declare error_table_$bad_conversion
				 fixed bin (35) external static;
	declare error_table_$moderr	 fixed bin (35) external static;
	declare error_table_$noarg	 fixed bin (35) external static;
	declare error_table_$noentry	 fixed bin (35) external static;
	declare error_table_$too_many_args
				 fixed bin (35) external static;
	declare error_table_$no_log_message
				 fixed bin (35) external static;


	declare log_data_$syserr_log_name
				 char (32) external static;
	declare log_data_$syserr_log_dir
				 char (168) external static;

	declare check_gate_access_	 entry (char (*), ptr, fixed bin (35));
	declare com_err_		 entry options (variable);
	declare command_query_	 entry () options (variable);
	declare continue_to_signal_	 entry (fixed binary (35));
	declare cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));

	declare cu_$arg_list_ptr	 entry returns (pointer);
	declare dm_misc_util_$get_log_path
				 entry (char (*));
	declare dsa_nit_$get_field	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare format_log_message_$init
				 entry (pointer);
	declare format_log_message_$adjust
				 entry (pointer, fixed bin (35));
	declare format_log_message_$free
				 entry (pointer);
	declare get_line_length_$switch
				 entry (pointer, fixed bin (35)) returns (fixed bin);
	declare get_system_free_area_	 entry () returns (ptr);
	declare system_area		 area based (get_system_free_area_ ());
	declare hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	declare hcs_$reset_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	declare ioa_		 entry () options (variable);
	declare iox_$look_iocb	 entry (char (*), pointer, fixed bin (35));
	declare ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	declare ipc_$decl_event_call_chn
				 entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
	declare ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	declare ipc_$cutoff		 entry (fixed bin (71), fixed bin (35));
	declare ipc_$reconnect	 entry (fixed bin (71), fixed bin (35));
	declare log_expand_select_$add entry (pointer, character (*), fixed binary (35));
	declare log_expand_select_$free
				 entry (pointer);
	declare log_expand_select_$print
				 entry (pointer, pointer, fixed binary);

	declare log_match_$add_match	 entry (pointer, char (*));
	declare log_match_$add_exclude entry (pointer, char (*));
	declare log_match_$add_match_data
				 entry (pointer, char (*));
	declare log_match_$add_exclude_data
				 entry (pointer, char (*));
	declare log_match_$clear_text_strings
				 entry (pointer);
	declare log_match_$clear_data_strings
				 entry (pointer);
	declare log_match_$add_match_data_class
				 entry (pointer, character (*));
	declare log_match_$add_exclude_data_class
				 entry (pointer, character (*));
	declare log_match_$clear_data_class_strings
				 entry (pointer);
	declare log_match_$add_severity
				 entry (pointer, fixed bin, fixed bin);
	declare log_match_$clear_severity
				 entry (pointer);
	declare log_match_$free	 entry (pointer);
	declare log_match_$print	 entry (pointer, pointer, fixed binary);
	declare log_read_$open	 entry (char (*), char (*), pointer, fixed bin (35));
	declare log_read_$open_long	 entry (character (*), character (*), pointer, pointer, fixed binary (35));
	declare log_read_$update	 entry (fixed binary (35), pointer, pointer, fixed binary (35));
	declare log_read_$close	 entry (pointer, fixed bin (35));
	declare log_read_$prev_message entry (pointer, pointer, fixed bin (35));
	declare log_read_$get_log_uid	 entry (pointer, bit (36) aligned, fixed binary (35));
	declare monitor_sys_log_wakeup_$timer
				 entry (pointer);

	declare pathname_		 entry (char (*), char (*)) returns (char (168));

	declare sub_err_		 entry () options (variable);
	declare ssu_$arg_count	 entry (ptr, fixed bin);
	declare ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	declare ssu_$destroy_invocation
				 entry (ptr);
	declare ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	declare ssu_$abort_line	 entry () options (variable);
	declare timer_manager_$alarm_wakeup
				 entry (fixed binary (71), bit (2), fixed binary (71));
	declare timer_manager_$reset_alarm_wakeup
				 entry (fixed binary (71));

	declare any_other		 condition;
	declare cleanup		 condition;

	declare COMMAND_NAME	 char (32) internal static options (constant) init ("monitor_sys_log");
	declare SYSERR_PATH		 char (10) internal static options (constant) init ("<>SYSERR<>");
	declare AS_PATH		 char (10) internal static options (constant) init ("<>AS_LOG<>");
	declare ADMIN_PATH		 char (10) internal static options (constant) init ("<>ADMIN<>");
	declare DM_PATH		 char (10) internal static options (constant) init ("<>DM<>");
	declare DSA_SL_PATH		 char (10) internal static options (constant) init ("<>DSASL<>");
	declare DSA_SAL_PATH	 char (10) internal static options (constant) init ("<>DSASAL<>");
	declare ALL_PATH		 char (10) internal static options (constant) init ("<>ALL<>");
	declare NUMBER_PATH		 char (10) internal static options (constant) init ("<>NUMBER<>");


	declare MC_LOG_DIR		 char (168) init (">system_control_dir>as_logs") int static options (constant);

	declare DEFAULT_LINE_LENGTH	 fixed bin internal static options (constant) init (132);
						/* assume a file of some sort */

	declare (abs, addr, after, before, char, codeptr, index, length, null, substr, unspec)
				 builtin;

	declare DM_READER_PROCEDURE	 char (32) init ("dm_log_read_") int static options (constant);
	declare DSA_READER_PROCEDURE	 char (32) init ("dsa_log_admin_gate_") int static options (constant);


	call initialize_options ();

	on condition (cleanup) call clean_up ();


	call ssu_$standalone_invocation (sci_ptr, COMMAND_NAME, "1.0", cu_$arg_list_ptr (), SSU_ABORT, code);
	if code ^= 0
	then do;
		call com_err_ (code, COMMAND_NAME, "Unable to create ssu invocation.");
		return;
	     end;


	call process_arguments$$find_log_and_action ();	/* sets opt to indicate what log and what is to be done with it */

	if opt.time_given_sw
	then /* one possible action is to set the clock */
	     do;
		monitor_sys_log_data_.wakeup_interval = opt.time;
		call reset_timer;
	     end;

	if opt.pathname = ""
	then /* just the time, or the time and -status */
	     if opt.status_sw
	     then call print_status_header ();
	     else ;
	else call process_log;			/* reparse args to do the real work */

	call ssu_$destroy_invocation (sci_ptr);
	go to MAIN_RETURN;


SSU_ABORT:
     procedure;
	call finished ();
     end SSU_ABORT;


MAIN_RETURN:					/* This is the ONLY return statement for this procedure */
	return;



finished:						/* This is a procedure in order to aid debugging; one */
     procedure ();					/* can set a breakpoint in it to catch all error returns */

	call clean_up ();

	goto MAIN_RETURN;

     end finished;


fault_masked:
     procedure;

	if substr (old_mask, 36, 1) = "0"b
	then call continue_to_signal_ ((0));
	else do;
		call hcs_$reset_ips_mask (old_mask, old_mask);
		monitor_sys_log_data_.initialized = "0"b;
		call sub_err_ (error_table_$unexpected_condition, COMMAND_NAME, ACTION_CANT_RESTART, null (), (0),
		     "Error signalled while manipulating database.");
	     end;
	return;
     end fault_masked;

clean_up:
     procedure ();

	if opt.free_from_opt
	then do;
		if (opt.lmd_ptr ^= null ())
		then call log_match_$free (opt.lmd_ptr);

		if (opt.log_read_ptr ^= null ())
		then call log_read_$close (opt.log_read_ptr, (0));

		if (log_message_format_ptr ^= null ())
		then call format_log_message_$free (log_message_format_ptr);
	     end;
	if sci_ptr ^= null ()
	then call ssu_$destroy_invocation (sci_ptr);

	return;
     end clean_up;

reset_timer:
     procedure;

	if monitor_sys_log_data_.active & monitor_sys_log_data_.wakeup_event_channel ^= 0
	then call timer_manager_$reset_alarm_wakeup (monitor_sys_log_data_.wakeup_event_channel);
	monitor_sys_log_data_.active = "0"b;

	if monitor_sys_log_data_.n_logs_on_timer = 0
	then return;
	if monitor_sys_log_data_.wakeup_event_channel = 0
	then do;
		call ipc_$create_ev_chn (monitor_sys_log_data_.wakeup_event_channel, code);
		if code ^= 0
		then call sub_err_ (code, COMMAND_NAME, ACTION_CANT_RESTART, null (), (0),
			"Failed to create event channel for log timer.");
		call ipc_$decl_event_call_chn (monitor_sys_log_data_.wakeup_event_channel,
		     monitor_sys_log_wakeup_$timer, null (), 0, code);
		if code ^= 0
		then call sub_err_ (code, COMMAND_NAME, ACTION_CANT_RESTART, null (), (0),
			"Failed to declare event call channel for log timer.");
	     end;
	monitor_sys_log_data_.active = "1"b;
	call timer_manager_$alarm_wakeup (monitor_sys_log_data_.wakeup_interval, "11"b,
	     monitor_sys_log_data_.wakeup_event_channel);

	return;
     end reset_timer;


/**** When this is called, opt has a pathname of a log (and
      bits for the special logs), and the opt bits that
      specify actions are set. This procedure must determine
      if the specified log is already being monitored.
      If this is incompatable with the control arguments,
      then it must abort.

      Otherwise, the action can be one of:

      replace: remove the current monitor and then do an add.
      modify:  fill up opt from an_entry, parse args changing opt,
      and then copy back from opt to an_entry.
*/

process_log:
     procedure;

	declare already_monitored	 bit (1) aligned;
	declare explicit_action	 bit (1) aligned;
	declare explicit_modification	 bit (1) aligned;

	explicit_action = opt.add_sw | opt.remove_sw | opt.modify_sw | opt.on_sw | opt.off_sw | opt.status_sw;
	explicit_modification = explicit_action & ^opt.add_sw;
	if opt.all_sw
	then do;
		if ^explicit_modification
		then call ssu_$abort_line (sci_ptr, 0, "-all requires -on, -off, -remove, or -status.");
		call process_all_logs;
		return;
	     end;

	call make_log_pathname;			/* turn <<X>> to FS path */
	call find_log;				/* if the specified log exists, then set log_index and an_entry_ptr */

	already_monitored = (log_index ^= 0);

	if opt.add_sw & already_monitored
	then call ssu_$abort_line (sci_ptr, 0,
		"You are already monitoring ^a. Use -replace or -modify to change its parameters.", opt.pathname);

	if explicit_modification & ^already_monitored
	then call ssu_$abort_line (sci_ptr, 0,
		"-^[modify^]^[replace^]^[remove^]^[on^]^[off^]^[status^] specified, but you are not monitoring ^a.",
		opt.modify_sw, opt.replace_sw, opt.remove_sw, opt.on_sw, opt.off_sw, opt.status_sw, opt.pathname);

	if ^explicit_action
	then if already_monitored
	     then opt.modify_sw = "1"b;		/* The default is to modify */
	     else opt.add_sw = "1"b;			/* unless its not there at all, so we add */

/**** Now we have enough information to know what we are doing */

	if opt.modify_sw				/* an_entry is valid, guaranteed */
	then do;
		opt.free_from_opt = "0"b;		/* we are putting live goodies in here */
		opt.expand_select_ptr = an_entry.expand_select_ptr;
		opt.lmd_ptr = an_entry.lmd_ptr;
		log_message_format_ptr = an_entry.format_ptr;
		opt.log_read_ptr = an_entry.log_read_ptr;
	     end;
	if opt.replace_sw
	then do;
		if log_index > 0			/* its OK to -update when nothing is there, it just adds */
		then call remove_log;		/* POOF */
		opt.replace_sw = "0"b;
		opt.add_sw = "1"b;
	     end;
	if opt.add_sw
	then call initialize_add_options;
	if opt.add_sw | opt.modify_sw
	then do;
		call process_arguments$$fill_opt_with_options ();
		if opt.add_sw
		then do;
			call open_log;		/* fills in opt with read_data_ptr */
			call make_new_entry;	/* given a findable log, create a slot for it */
		     end;
		call fill_entry_from_opt;
	     end;
	else call process_existing_log;		/* take care of -remove, -on, -off, -status */
	return;
     end process_log;



/**** This procedure sets log_index to 0 or the index of a log
      with a pre-existing monitor. It always leaves an_entry_ptr
      consistent with log_index. */

find_log:
     procedure;

	log_index = 0;				/* assume no match */
	an_entry_ptr = null ();

	if monitor_sys_log_data_.initialized
	then monitor_sys_log_array_ptr = monitor_sys_log_data_.log_array_ptr;

	if ^monitor_sys_log_data_.initialized | monitor_sys_log_data_.n_logs = 0
	     | monitor_sys_log_data_.log_array_ptr = null ()
	then return;				/* surely no match */

	if opt.log_number > 0
	then do;					/* asked by number */
		if opt.log_number > monitor_sys_log_array.n_entries
		then return;
		if monitor_sys_log_array.entry (opt.log_number).dir_name = ""
		then return;
		log_index = opt.log_number;
		an_entry_ptr = addr (monitor_sys_log_array.entry (log_index));
		return;
	     end;

	/*** done with the numbered case. */

	do log_index = 1 to monitor_sys_log_array.n_entries;
	     an_entry_ptr = addr (monitor_sys_log_array.entry (log_index));
	     if an_entry.dir_name = ""
	     then ;				/* not in use */
	     else if opt.the_syserr_log_sw & an_entry.the_syserr_log
	     then return;
	     else if opt.the_as_log_sw & an_entry.the_as_log
	     then return;
	     else if opt.the_admin_log_sw & an_entry.the_admin_log
	     then return;
	     else if opt.the_dm_log_sw & an_entry.the_dm_log
	     then return;
	     else if opt.the_dsas_log_sw & an_entry.the_dsas_log
	     then return;
	     else if opt.the_dsasa_log_sw & an_entry.the_dsasa_log
	     then return;
	     else if same_pathname ()
	     then return;
	end;
	log_index = 0;
	return;

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

	declare (new_uid, old_uid)	 bit (36) aligned;
	declare temp_opening	 pointer;

	if an_entry.the_syserr_log | an_entry.the_as_log | an_entry.the_admin_log | an_entry.the_dm_log
	     | an_entry.the_dsas_log | an_entry.the_dsasa_log
	then return ("0"b);				/* already checked */

	call open_log;				/* sets opt.log_read_ptr */
	temp_opening = opt.log_read_ptr;
	opt.log_read_ptr = null ();
	call log_read_$get_log_uid (temp_opening, new_uid, code);
	call log_read_$close (temp_opening, (0));
	if code ^= 0
	then return ("0"b);
	call log_read_$update (an_entry.last_sequence, an_entry.log_read_ptr, an_entry.last_message_ptr, code);
	call log_read_$get_log_uid (an_entry.log_read_ptr, old_uid, code);
	if code ^= 0
	then return ("0"b);
	if new_uid = old_uid
	then return ("1"b);
	else return ("0"b);

     end same_pathname;
     end find_log;


print_status_header:
     procedure;

	declare select_timer	 fixed bin;

	if ^monitor_sys_log_data_.initialized | monitor_sys_log_data_.n_logs = 0
	then do;
		call ioa_ ("No logs, timer wakeup interval ^d seconds.", monitor_sys_log_data_.wakeup_interval);
		return;
	     end;

	if monitor_sys_log_data_.n_logs = 0
	then select_timer = 1;			/* don't print */
	else if monitor_sys_log_data_.n_logs = 1
	then if monitor_sys_log_data_.n_logs_on_timer = 1
	     then select_timer = 2;
	     else select_timer = 3;
	else if monitor_sys_log_data_.n_logs_on_timer = monitor_sys_log_data_.n_logs
	then select_timer = 4;			/* all */
	else if monitor_sys_log_data_.n_logs_on_timer = 0
	then select_timer = 5;			/* none */
	else select_timer = 6;

	call ioa_ (
	     "^d log^[s^]^[^s^;^s on timer^;^s^;^s, all on timer wakeup^;^s, none on timer wakeup^;, ^d on timer wakeup^]. Wakeup interval ^d seconds.",
	     monitor_sys_log_data_.n_logs, monitor_sys_log_data_.n_logs ^= 1, select_timer,
	     monitor_sys_log_data_.n_logs_on_timer, monitor_sys_log_data_.wakeup_interval);
	return;
     end print_status_header;



process_existing_log:
     procedure;

	if opt.status_sw
	then call status_log;
	else if opt.off_sw
	then call disable_log;
	else if opt.on_sw
	then call enable_log;
	else if opt.remove_sw
	then call remove_log;

	return;
     end process_existing_log;

process_all_logs:
     procedure;

	monitor_sys_log_array_ptr = monitor_sys_log_data_.log_array_ptr;

	if opt.status_sw
	then do;
		call print_status_header;
		if monitor_sys_log_data_.n_logs = 0
		then return;
	     end;
	else if monitor_sys_log_data_.n_logs = 0
	then call ssu_$abort_line (sci_ptr, 0, "There are no monitors set.");


	do log_index = 1 to monitor_sys_log_array.n_entries;
	     an_entry_ptr = addr (monitor_sys_log_array.entry (log_index));
	     if an_entry.dir_name ^= ""
	     then call process_existing_log;
	end;
	return;
     end process_all_logs;

status_log:
     procedure;

	call ioa_ (
	     "# ^d: Pathname ^a^[ (the syserr log)^]^[ (the Answering Service log)^]^[ (the Admin command log)^]^[ (the DM system log)^]^[ (the DSA system log)^]^[ (the DSA system aep log)^]",
	     log_index, pathname_ (an_entry.dir_name, an_entry.entryname), an_entry.the_syserr_log, an_entry.the_as_log,
	     an_entry.the_admin_log, an_entry.the_dm_log, an_entry.the_dsas_log, an_entry.the_dsasa_log);
	call ioa_ ("   ^[Examined on timer^;Registered to receive wakeups on messages^]", ^an_entry.registered);
	if an_entry.inhibited
	then call ioa_ ("   Currently inhibited.");
	if an_entry.expand_select_ptr ^= null ()
	then call log_expand_select_$print (an_entry.expand_select_ptr, iox_$user_output, 3);
	if an_entry.lmd_ptr ^= null ()
	then call log_match_$print (an_entry.lmd_ptr, iox_$user_output, 3);
	/*** The formatting options are too hairy */
	call ioa_ ("   Last sequence number ^d.", an_entry.last_sequence);
	return;
     end status_log;

disable_log:
     procedure;

	if an_entry.inhibited
	then call ssu_$abort_line (sci_ptr, 0, "Log ^a is already off.", an_entry.entryname);
	an_entry.inhibited = "1"b;
	if an_entry.registered
	then call ipc_$cutoff (an_entry.registered_wakeup_event_channel, (0));
	else call reset_timer;
	return;
     end disable_log;

enable_log:
     procedure;

	if ^an_entry.inhibited
	then call ssu_$abort_line (sci_ptr, 0, "Log ^a is already on.", an_entry.entryname);
	call log_read_$update (an_entry.last_sequence, an_entry.log_read_ptr, an_entry.last_message_ptr, (0));
						/* ignore this code */
	an_entry.last_message_ptr = null ();
	call log_read_$prev_message (an_entry.log_read_ptr, an_entry.last_message_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to find last message in log ^a to process -on.",
		an_entry.entryname);
	an_entry.last_sequence = an_entry.last_message_ptr -> log_message.sequence;
	an_entry.prev_message_ptr = null ();
	an_entry.inhibited = "0"b;
	if an_entry.registered
	then call ipc_$reconnect (an_entry.registered_wakeup_event_channel, (0));
	else call reset_timer;
	return;
     end enable_log;

remove_log:
     procedure;

	if an_entry.registered
	then do;					/* de-register, etc */
	     end;
	else monitor_sys_log_data_.n_logs_on_timer = monitor_sys_log_data_.n_logs_on_timer - 1;
	monitor_sys_log_data_.n_logs = monitor_sys_log_data_.n_logs - 1;

	old_mask = ""b;
	on any_other call fault_masked;
	on cleanup
	     begin;
		if substr (old_mask, 36, 1) = "1"b
		then call hcs_$reset_ips_mask (old_mask, old_mask);
	     end;
	call hcs_$set_ips_mask (""b, old_mask);
	an_entry.dir_name = "";			/* chase handlers away */
	call hcs_$reset_ips_mask (old_mask, old_mask);
	revert any_other, cleanup;

	call log_read_$close (an_entry.log_read_ptr, (0));
	if an_entry.expand_select_ptr ^= null ()
	then call log_expand_select_$free (an_entry.expand_select_ptr);
	if an_entry.lmd_ptr ^= null ()
	then call log_match_$free (an_entry.lmd_ptr);
	if an_entry.format_ptr ^= null ()
	then call format_log_message_$free (an_entry.format_ptr);
	if an_entry.registered_wakeup_event_channel ^= 0
	then call ipc_$delete_ev_chn (an_entry.registered_wakeup_event_channel, (0));
	if an_entry.call_command.ptr ^= null ()
	then begin;
		declare call_command_string	 char (an_entry.call_command.length) based (an_entry.call_command.ptr);
		free call_command_string;
	     end;

	call clear_entry;
	call reset_timer;
	return;
     end remove_log;

make_new_entry:
     procedure;

	if ^monitor_sys_log_data_.initialized
	then call initialize_data ();			/* sets array ptr if needed */

/**** we have to mask IPS to avoid QUIT and foolishness */

	old_mask = ""b;
	on any_other call fault_masked;
	on cleanup
	     begin;
		if substr (old_mask, 36, 1) = "1"b
		then call hcs_$reset_ips_mask (old_mask, old_mask);
	     end;
	call hcs_$set_ips_mask (""b, old_mask);

	do log_index = 1 to monitor_sys_log_array.n_entries;
	     if monitor_sys_log_array.entry (log_index).dir_name = ""
	     then go to HAVE_EMPTY_SLOT;
	end;

	call reallocate_array ();

HAVE_EMPTY_SLOT:
	an_entry_ptr = addr (monitor_sys_log_array.entry (log_index));
						/* set pointer for caller */

	call hcs_$reset_ips_mask (old_mask, old_mask);
	revert any_other, cleanup;

     end make_new_entry;



fill_entry_from_opt:
     procedure;

	declare log_last_sequence	 fixed bin (35);
	declare log_last_message_ptr	 pointer;

	if opt.add_sw
	then call get_last_message_info (log_last_sequence, log_last_message_ptr);

	if ^opt.prefix_given_sw
	then do;
		if opt.the_syserr_log_sw
		then log_message_format.prefix = "SYSERR: ";
		else if opt.the_as_log_sw
		then log_message_format.prefix = "AS: ";
		else if opt.the_admin_log_sw
		then log_message_format.prefix = "ADMIN: ";
		else if opt.the_dm_log_sw
		then log_message_format.prefix = "DM: ";
		else if opt.the_dsas_log_sw
		then log_message_format.prefix = "DSASL: ";
		else if opt.the_dsasa_log_sw
		then log_message_format.prefix = "DSASAL: ";
		else log_message_format.prefix = rtrim (log_ename) || ": ";
		call adjust_log_message_format ("Adding default prefix", (log_message_format.prefix));
	     end;

	an_entry.dir_name = log_dname;
	an_entry.entryname = log_ename;
	an_entry.log_read_ptr = opt.log_read_ptr;
	an_entry.the_syserr_log = opt.the_syserr_log_sw;
	an_entry.the_as_log = opt.the_as_log_sw;
	an_entry.the_admin_log = opt.the_admin_log_sw;
	an_entry.the_dm_log = opt.the_dm_log_sw;
	an_entry.the_dsas_log = opt.the_dsas_log_sw;
	an_entry.the_dsasa_log = opt.the_dsasa_log_sw;
	an_entry.registered = "0"b;			/* not yet implemented */
	an_entry.inhibited = "0"b;
	an_entry.expand_select_ptr = opt.expand_select_ptr;
	an_entry.lmd_ptr = opt.lmd_ptr;
	an_entry.iocb_ptr = opt.iocb_ptr;
	an_entry.octal_sw = opt.octal_sw;
	an_entry.interpret_sw = opt.interpret_sw;
	an_entry.process_id_sw = opt.process_id_sw;
	an_entry.data_class_sw = opt.data_class_sw;

	an_entry.format_ptr = log_message_format_ptr;
	if opt.add_sw
	then do;
		an_entry.last_sequence = log_last_sequence;
						/* found by open_log */
		an_entry.last_message_ptr = log_last_message_ptr;
		an_entry.prev_message_ptr = null ();
	     end;
	if opt.call_given_sw
	then begin;
		declare copy_of_call_command	 char (an_entry.call_command.length) based (an_entry.call_command.ptr);
		an_entry.call_command.length = opt.call_command.length;
		allocate copy_of_call_command in (system_area);
		copy_of_call_command = opt_call_command_string;
	     end;

	if opt.add_sw
	then do;					/* This won't be right if we are modifying the registered status. Implementors of -registered beware */
		monitor_sys_log_data_.n_logs = monitor_sys_log_data_.n_logs + 1;
		if ^an_entry.registered
		then do;
			monitor_sys_log_data_.n_logs_on_timer = monitor_sys_log_data_.n_logs_on_timer + 1;
			if monitor_sys_log_data_.n_logs_on_timer = 1
						/* first one */
			then call reset_timer ();
		     end;

	     end;

	return;
     end fill_entry_from_opt;

make_log_pathname:
     procedure ();

	if opt.all_sw
	then return;
	if (opt.pathname = NUMBER_PATH)
	then return;

	if (opt.pathname = SYSERR_PATH)
	then do;
		log_dname = log_data_$syserr_log_dir;
		log_ename = log_data_$syserr_log_name;
		opt.pathname = pathname_ (log_dname, log_ename);
	     end;

	else if opt.pathname = AS_PATH
	then do;
		log_dname = ">system_control_dir>as_logs";
		log_ename = "log";
		opt.pathname = pathname_ (log_dname, log_ename);
	     end;
	else if opt.pathname = ADMIN_PATH
	then do;
		log_dname = ">system_control_dir>as_logs";
		log_ename = "admin_log";
		opt.pathname = pathname_ (log_dname, log_ename);
	     end;
	else if opt.pathname = DM_PATH
	then do;
		call dm_misc_util_$get_log_path (dm_system_log_path);
		call expand_pathname_ (dm_system_log_path, log_dname, log_ename, 0);
		opt.pathname = dm_system_log_path;
		opt.reader_procedure = DM_READER_PROCEDURE;
	     end;
	else if opt.pathname = DSA_SL_PATH
	then do;

		/*** Check to see if we will succeed. */

		call check_gate_access_ (DSA_READER_PROCEDURE, null (), code);

		if code = error_table_$noentry
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "DSA is not installed on this system.");
		else if code = error_table_$moderr
		then call ssu_$abort_line (sci_ptr, code, "You need e access to ^a to read the DSA log.",
			DSA_READER_PROCEDURE);
		else if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Trying to check the access to: ^a.", DSA_READER_PROCEDURE);

		/*** The code was 0, proceed. */

		else call dsa_nit_$get_field ("mna_general_info", "", "dsa_system_log", dsa_system_log_path, code);

		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Cannot find the name of the dsa system log.");

		call expand_pathname_ (dsa_system_log_path, log_dname, log_ename, 0);
		opt.pathname = dsa_system_log_path;
		opt.reader_procedure = DSA_READER_PROCEDURE;
	     end;
	else if opt.pathname = DSA_SAL_PATH
	then do;

		/*** Check to see if we will succeed. */

		call check_gate_access_ (DSA_READER_PROCEDURE, null (), code);

		if code = error_table_$noentry
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "DSA is not installed on this system.");
		else if code = error_table_$moderr
		then call ssu_$abort_line (sci_ptr, code, "You need e access to ^a to read the DSA log.",
			DSA_READER_PROCEDURE);
		else if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Trying to check the access to: ^a.", DSA_READER_PROCEDURE);

		/*** The code was 0, proceed. */

		else call dsa_nit_$get_field ("mna_general_info", "", "dsa_system_aep_log", dsa_system_log_path, code)
			;

		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Cannot find the name of the dsa system aep log.");

		call expand_pathname_ (dsa_system_log_path, log_dname, log_ename, 0);
		opt.pathname = dsa_system_log_path;
		opt.reader_procedure = DSA_READER_PROCEDURE;
	     end;
	else do;
		call expand_pathname_ (opt.pathname, log_dname, log_ename, code);
		if (code ^= 0)
		then call ssu_$abort_line (sci_ptr, code, "Log pathname ^a", opt.pathname);
	     end;

	return;
     end make_log_pathname;

open_log:
     procedure;

	if opt.reader_procedure ^= ""
	then do;
		log_open_info.version = LOG_READ_OPEN_INFO_VERSION_1;
		log_open_info.reader_procedure = opt.reader_procedure;
		log_open_info.allocation_area_ptr = get_system_free_area_ ();
						/* since we never use hold_message, it is reasonable for log_read_ to allocate the 2 copies it keeps around in here */
		log_open_info.allocate_copies = "0"b;	/* That is the inner-ring's job */
		call log_read_$open_long (log_dname, log_ename, addr (log_open_info), opt.log_read_ptr, code);
	     end;
	else call log_read_$open (log_dname, log_ename, opt.log_read_ptr, code);

	if (code ^= 0)
	then call ssu_$abort_line (sci_ptr, code, "Cannot open ^a", opt.pathname);

	return;
     end open_log;

get_last_message_info:
     procedure (last_seq, last_msg_ptr);

	declare last_seq		 fixed bin (35);
	declare last_msg_ptr	 pointer;

	last_msg_ptr = null ();
	call log_read_$prev_message (opt.log_read_ptr, last_msg_ptr, code);
	if code ^= 0 & code ^= error_table_$no_log_message/* no_log_message happens if the log is empty. */
	then call ssu_$abort_line (sci_ptr, code, "Failed to find last message in log ^a.", opt.pathname);
						/* This may need to know about empty logs ... */
	if last_msg_ptr = null ()
	then last_seq = -1;
	else last_seq = last_msg_ptr -> log_message.sequence;
	return;
     end get_last_message_info;

initialize_data:
     procedure;

	declare 1 init_entry	 aligned like monitor_sys_log_array.entry automatic;

	declare new_array_ptr	 pointer;
	declare x			 fixed bin;

	msl_n_entries = 100;			/* lots */
	allocate monitor_sys_log_array in (system_area);
	call set_init_entry ();

	monitor_sys_log_array.entry (*) = init_entry;
	monitor_sys_log_data_.log_array_ptr = monitor_sys_log_array_ptr;
	monitor_sys_log_data_.initialized = "1"b;
	return;

reallocate_array:
     entry;

	msl_n_entries = 2 * monitor_sys_log_array.n_entries;
	allocate monitor_sys_log_array in (system_area) set (new_array_ptr);
	call set_init_entry ();
	new_array_ptr -> monitor_sys_log_array.entry (*) = init_entry;
	do x = 1 to monitor_sys_log_array.n_entries;
	     new_array_ptr -> monitor_sys_log_array.entry (x) = monitor_sys_log_array.entry (x);
	end;
	log_index = x;				/* first free slot in new array */

	old_mask = ""b;
	on any_other call fault_masked;
	on cleanup
	     begin;
		if substr (old_mask, 36, 1) = "1"b
		then call hcs_$reset_ips_mask (old_mask, old_mask);
	     end;
	call hcs_$set_ips_mask (""b, old_mask);
	monitor_sys_log_data_.log_array_ptr = new_array_ptr;
	free monitor_sys_log_array;
	monitor_sys_log_array_ptr = new_array_ptr;
	call hcs_$reset_ips_mask (old_mask, old_mask);
	revert any_other, cleanup;
	return;

clear_entry:
     entry;					/* assumes an_entry is the victim */

	call set_init_entry ();
	an_entry = init_entry;
	return;

set_init_entry:
     procedure;

	init_entry.dir_name = "";
	init_entry.entryname = "";
	init_entry.log_read_ptr = null ();
	init_entry.the_syserr_log = "0"b;
	init_entry.the_as_log = "0"b;
	init_entry.the_admin_log = "0"b;
	init_entry.the_dm_log = "0"b;
	init_entry.the_dsas_log = "0"b;
	init_entry.the_dsasa_log = "0"b;
	init_entry.registered = "0"b;
	init_entry.inhibited = "0"b;
	init_entry.expand_select_ptr = null ();
	init_entry.interpret_sw = "0"b;
	init_entry.octal_sw = "0"b;
	init_entry.lmd_ptr = null ();
	init_entry.format_ptr = null ();
	init_entry.iocb_ptr = null ();
	init_entry.call_command.ptr = null ();
	init_entry.call_command.length = 0;
	init_entry.last_sequence = 0;
	init_entry.last_message_ptr = null ();
	init_entry.prev_message_ptr = null ();
	init_entry.registered_wakeup_event_channel = 0;
	return;
     end set_init_entry;

     end initialize_data;


initialize_options:
     procedure ();

/* This must be run before the cleanup handler gets set up */

	unspec (opt) = ""b;				/* Turn all options off */
	opt.pointers = null ();			/* Aggregate assignment */
	opt.free_from_opt = "1"b;
	opt.pathname = "";
	opt.iocb_ptr = iox_$user_output;
	opt.call_command.ptr = null ();
	opt.call_command.length = 0;
	log_message_format_ptr = null ();
	opt.reader_procedure = "";			/* Default */
	return;
     end initialize_options;

initialize_add_options:
     procedure;

	call format_log_message_$init (log_message_format_ptr);
	log_message_format.continuation_indent = 3;	/* economize on space */
	log_message_format.caller = COMMAND_NAME;
	log_message_format.equal_sw = "0"b;

	log_message_format.line_lth = get_line_length_$switch (opt.iocb_ptr, code);
	if (code ^= 0)
	then log_message_format.line_lth = DEFAULT_LINE_LENGTH;
						/* Pretend to be a printer, by default */

	call adjust_log_message_format ("Initializing log_message_format structure", "");

	return;
     end initialize_add_options;


process_arguments$$find_log_and_action:
     procedure ();

	declare arg		 char (arg_lth) based (arg_ptr);
	declare arg_lth		 fixed bin (21);
	declare arg_ptr		 pointer;
	declare arg_count		 fixed bin;
	declare arg_idx		 fixed bin;

	declare looking_for		 fixed bin;
	declare saved_looking_for	 fixed bin;
	declare number_arg		 char (20) varying;
	declare iocb_arg		 char (32) varying;
	declare temp_v_string_arg	 char (200) varying;
	declare pass		 fixed bin;

	declare FIND_LOG		 fixed bin init (1) int static options (constant);
	declare DO_CONTROL_ARGS	 fixed bin init (2) int static options (constant);

	declare LOG_PATHNAME	 init (1) fixed bin internal static options (constant);
	declare MATCH_STRING	 init (2) fixed bin internal static options (constant);
	declare EXCLUDE_STRING	 init (3) fixed bin internal static options (constant);
	declare MATCH_DATA_STRING	 init (4) fixed bin internal static options (constant);
	declare EXCLUDE_DATA_STRING	 init (5) fixed bin internal static options (constant);
	declare SEVERITY		 init (6) fixed bin internal static options (constant);
	declare CALL_COMMAND	 init (7) fixed bin internal static options (constant);
	declare EXPAND_TYPE		 init (8) fixed bin internal static options (constant);
	declare MC_PATHNAME		 init (9) fixed bin internal static options (constant);
	declare MATCH_DATA_CLASS_STRING
				 init (10) fixed bin internal static options (constant);
	declare EXCLUDE_DATA_CLASS_STRING
				 init (11) fixed bin internal static options (constant);


	pass = FIND_LOG;
	go to COMMON;

process_arguments$$fill_opt_with_options:
     entry;

	pass = DO_CONTROL_ARGS;

COMMON:
	call ssu_$arg_count (sci_ptr, arg_count);

	looking_for = 0 - LOG_PATHNAME;		/* Start out "casually" looking for a pathname */

	do arg_idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_lth);

	     if (looking_for > 0)
	     then do;				/* First one after a control argument */
		     call process_looking_for ();	/* -match -fred matches "-fred", but */
		     looking_for = 0 - looking_for;	/* -match str -fred is an error */
		end;				/* "Casually" looking for signalled by negative value */

	     else if (arg = "-match") | (arg = "-mh")
	     then do;
		     looking_for = MATCH_STRING;
		end;
	     else if (arg = "-exclude") | (arg = "-ex")
	     then do;
		     looking_for = EXCLUDE_STRING;
		end;

	     else if (arg = "-match_data_class") | (arg = "-mdc")
	     then do;
		     looking_for = MATCH_DATA_CLASS_STRING;
		end;
	     else if (arg = "-exclude_data_class") | (arg = "-exdc")
	     then do;
		     looking_for = EXCLUDE_DATA_CLASS_STRING;
		end;
	     else if (arg = "-match_data") | (arg = "-md")
	     then do;
		     looking_for = MATCH_DATA_STRING;
		end;
	     else if (arg = "-exclude_data") | (arg = "-exd")
	     then do;
		     looking_for = EXCLUDE_DATA_STRING;
		end;
	     else if (arg = "-all_text") | (arg = "-atxt")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     call log_match_$clear_text_strings (opt.lmd_ptr);
			end;
		end;
	     else if (arg = "-all_data") | (arg = "-ad")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     call log_match_$clear_data_strings (opt.lmd_ptr);
			end;
		end;

	     else if (arg = "-all_data_class") | (arg = "-adc")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     call log_match_$clear_data_class_strings (opt.lmd_ptr);
			end;
		end;


	     else if (arg = "-severity") | (arg = "-sv") | (arg = "-action")
	     then do;
		     looking_for = SEVERITY;
		end;

	     else if (arg = "-all_severities") | (arg = "-asv")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then call log_match_$clear_severity (opt.lmd_ptr);
		end;

	     else if (arg = "-expand") | (arg = "-exp")
	     then do;
		     looking_for = (0 - EXPAND_TYPE);
		     opt.expand_sw = "1"b;
		end;
	     else if (arg = "-no_expand") | (arg = "-nexp")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     opt.expand_sw = "0"b;
			     opt.octal_sw = "0"b;
			     opt.interpret_sw = "0"b;
			end;
		end;

	     else if (arg = "-octal") | (arg = "-oc")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     opt.expand_sw = "1"b;
			     opt.octal_sw = "1"b;
			end;
		end;
	     else if (arg = "-interpret") | (arg = "-int") | (arg = "-it")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     opt.expand_sw = "1"b;
			     opt.interpret_sw = "1"b;
			end;
		end;

	     else if (arg = "-no_process_id") | (arg = "-npid")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then opt.process_id_sw = "0"b;
		end;
	     else if (arg = "-process_id") | (arg = "-pid")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then opt.process_id_sw = "1"b;
		end;

	     else if (arg = "-no_data_class") | (arg = "-ndc")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then opt.data_class_sw = "0"b;
		end;

	     else if (arg = "-data_class") | (arg = "-dc")
	     then do;
		     if (pass = DO_CONTROL_ARGS)
		     then opt.data_class_sw = "1"b;
		end;

	     else if (arg = "-procedure") | (arg = "-proc")
	     then do;
		     call get_next_arg (opt.reader_procedure);
		end;

	     else if (arg = "-line_length") | (arg = "-ll")
	     then do;
		     call get_next_arg (number_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     log_message_format.line_lth = cv_dec_check_ ((number_arg), code);
			     if (code ^= 0) | (log_message_format.line_lth < 25)
				| (log_message_format.line_lth > 500)
			     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				     "Line length must be between 25 and 500, not ^a", number_arg);

			     call adjust_log_message_format ("Processing -line_length.", arg);
			end;
		end;				/* Of -line_length processing */

	     else if (arg = "-output_switch") | (arg = "-osw")
	     then do;
		     call get_next_arg (iocb_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     call iox_$look_iocb ((iocb_arg), opt.iocb_ptr, code);
			     if (code ^= 0)
			     then call ssu_$abort_line (sci_ptr, code, "I/O switch ^a", iocb_arg);
			     log_message_format.line_lth = get_line_length_$switch (opt.iocb_ptr, code);
			     if (code ^= 0)
			     then /* Must reset the line length, also reapply the default */
				log_message_format.line_lth = DEFAULT_LINE_LENGTH;

			     call adjust_log_message_format ("Setting line length from -output_switch", arg);
			end;
		end;				/* Of -line_length processing */

	     else if (arg = "-indent") | (arg = "-ind") | (arg = "-in")
	     then do;
		     call get_next_arg (number_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     log_message_format.indentation = cv_dec_check_ ((number_arg), code);
			     if (code ^= 0) | (log_message_format.indentation < 0)
				| (log_message_format.indentation > 50)
			     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				     "Indentation must be between 0 and 50, not ^a", number_arg);

			     call adjust_log_message_format ("Processing -indent", arg);
			end;
		end;				/* Of -indent processing */

	     else if (arg = "-continuation_indent") | (arg = "-ci")
	     then do;
		     call get_next_arg (number_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     if number_arg = "std" | number_arg = "standard"
			     then log_message_format.continuation_indent = -1;
			     else do;
				     log_message_format.continuation_indent = cv_dec_check_ ((number_arg), code);
				     if (code ^= 0) | (log_message_format.continuation_indent < 0)
					| (log_message_format.continuation_indent > 50)
				     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
					     "Continuation indent must be between 0 and 50 or ""standard"", not ^a",
					     number_arg);
				end;
			     call adjust_log_message_format ("Processing -continuation_indent", (number_arg));
			end;
		end;				/* Of -continuation_indent processing */

	     else if (arg = "-prefix") | (arg = "-pfx")
	     then do;
		     call get_next_arg (temp_v_string_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     opt.prefix_given_sw = "1"b;
			     log_message_format.prefix = temp_v_string_arg;
			     call adjust_log_message_format ("Processing -prefix", arg);
			end;
		end;				/* Of -prefix processing */


	     else if (arg = "-time_format") | (arg = "-tfmt")
	     then do;
		     call get_next_arg (temp_v_string_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     log_message_format.time_format = temp_v_string_arg;
			     call adjust_log_message_format ("Processing -time_format", arg);
			end;
		end;

	     else if (arg = "-date_format") | (arg = "-dfmt")
	     then do;
		     call get_next_arg (temp_v_string_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     log_message_format.date_format = temp_v_string_arg;
			     call adjust_log_message_format ("Processing -date_format", arg);
			end;
		end;
	     else if (arg = "-all") | (arg = "-a")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     if opt.pathname ^= ""
			     then call two_logs;
			     opt.all_sw = "1"b;
			     opt.pathname = ALL_PATH;
			end;
		end;
	     else if (arg = "-mc_log") | (arg = "-mcl")
	     then looking_for = MC_PATHNAME;
	     else if (arg = "-number_format") | (arg = "-nfmt")
	     then do;
		     call get_next_arg (temp_v_string_arg);
		     if (pass = DO_CONTROL_ARGS)
		     then do;
			     log_message_format.number_format = temp_v_string_arg;
			     call adjust_log_message_format ("Processing -number_format", arg);
			end;
		end;

	     else if (arg = "-add")
	     then if (pass = FIND_LOG)
		then opt.add_sw = "1"b;
		else ;
	     else if (arg = "-remove") | (arg = "-rm")
	     then if (pass = FIND_LOG)
		then opt.remove_sw = "1"b;
		else ;
	     else if (arg = "-on")
	     then if (pass = FIND_LOG)
		then opt.on_sw = "1"b;
		else ;
	     else if (arg = "-off")
	     then if (pass = FIND_LOG)
		then opt.off_sw = "1"b;
		else ;

	     else if (arg = "-replace") | (arg = "-rp")
	     then if (pass = FIND_LOG)
		then opt.replace_sw = "1"b;
		else ;

	     else if (arg = "-update") | (arg = "-ud")
	     then if (pass = FIND_LOG)
		then opt.replace_sw = "1"b;
		else ;
	     else if (arg = "-status") | (arg = "-st")
	     then if (pass = FIND_LOG)
		then opt.status_sw = "1"b;
		else ;

	     else if (arg = "-time") | (arg = "-tm")
	     then do;
		     call get_next_arg (number_arg);
		     if (pass = FIND_LOG)
		     then do;
			     opt.time = cv_dec_check_ ((number_arg), code);
			     opt.time_given_sw = "1"b;
			     if code ^= 0 | opt.time < 1
			     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				     "-time must be followed by a positive number of seconds.");
			end;
		end;

	     else if (arg = "-number") | (arg = "-nb")
	     then do;
		     call get_next_arg (number_arg);
		     if (pass = FIND_LOG)
		     then do;
			     opt.log_number = cv_dec_check_ ((number_arg), code);
			     if opt.pathname ^= ""
			     then call two_logs;
			     opt.pathname = NUMBER_PATH;
			     if code ^= 0 | opt.log_number < 1
			     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				     "-number must be followed by a positive number.");
			end;
		end;
	     else if (arg = "-syserr")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     opt.pathname = SYSERR_PATH;
			     opt.the_syserr_log_sw = "1"b;
			end;
		end;

	     else if (arg = "-answering_service") | (arg = "-as")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     opt.pathname = AS_PATH;
			     opt.the_as_log_sw = "1"b;
			end;
		end;
	     else if (arg = "-admin")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     opt.pathname = ADMIN_PATH;
			     opt.the_admin_log_sw = "1"b;
			end;
		end;

	     else if (arg = "-dm_system_log") | (arg = "-dms")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     opt.pathname = DM_PATH;
			     opt.the_dm_log_sw = "1"b;
			end;
		end;

	     else if (arg = "-dsa_sys_log") | (arg = "-dsasl")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     opt.pathname = DSA_SL_PATH;
			     opt.the_dsas_log_sw = "1"b;
			end;
		end;

	     else if (arg = "-dsa_sys_aep_log") | (arg = "-dsasal")
	     then do;
		     if (pass = FIND_LOG)
		     then do;
			     opt.pathname = DSA_SAL_PATH;
			     opt.the_dsasa_log_sw = "1"b;
			end;
		end;

	     else if (arg = "-call")
	     then do;
		     opt.call_given_sw = "1"b;
		     looking_for = CALL_COMMAND;
		end;

	     else if (char (arg, 1) = "-")
	     then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);

	     else call process_looking_for ();
	end;					/* of loop through arguments */

	if (pass = FIND_LOG)
	then call check_options ();
	if (pass = DO_CONTROL_ARGS)
	then if opt.expand_sw & ^(opt.octal_sw | opt.interpret_sw)
	     then opt.interpret_sw = "1"b;		/* If neither specified, default is -interpret */

	return;					/* End of argument processing */


process_looking_for:
     procedure ();

	declare really_looking_for	 fixed bin;
	declare severity1		 fixed bin;
	declare severity2		 fixed bin;


	really_looking_for = abs (looking_for);

	if (really_looking_for = LOG_PATHNAME)
	then do;
		if (pass = FIND_LOG)
		then do;
			if (opt.pathname ^= "")
			then call two_logs;
			opt.pathname = arg;
		     end;
	     end;

	else if (really_looking_for = MC_PATHNAME)
	then do;
		if (pass = FIND_LOG)
		then do;
			if (opt.pathname ^= "")
			then call two_logs;
			if search (arg, "<>") > 0
			then call ssu_$abort_line (sci_ptr, 0,
				"-log must be followed by a log entryname of a log in >sc1>as_logs.");
			opt.pathname = pathname_ (MC_LOG_DIR, arg);
		     end;
	     end;

	else if (really_looking_for = MATCH_STRING)
	then if (pass = DO_CONTROL_ARGS)
	     then call log_match_$add_match (opt.lmd_ptr, arg);
	     else ;

	else if (really_looking_for = EXCLUDE_STRING)
	then if (pass = DO_CONTROL_ARGS)
	     then call log_match_$add_exclude (opt.lmd_ptr, arg);
	     else ;

	else if (really_looking_for = MATCH_DATA_CLASS_STRING)
	then if (pass = DO_CONTROL_ARGS)
	     then call log_match_$add_match_data_class (opt.lmd_ptr, arg);
	     else ;

	else if (really_looking_for = EXCLUDE_DATA_CLASS_STRING)
	then if (pass = DO_CONTROL_ARGS)
	     then call log_match_$add_exclude_data_class (opt.lmd_ptr, arg);
	     else ;

	else if (really_looking_for = MATCH_DATA_STRING)
	then if (pass = DO_CONTROL_ARGS)
	     then call log_match_$add_match_data (opt.lmd_ptr, arg);
	     else ;

	else if (really_looking_for = EXCLUDE_DATA_STRING)
	then if (pass = DO_CONTROL_ARGS)
	     then call log_match_$add_exclude_data (opt.lmd_ptr, arg);
	     else ;

	else if (really_looking_for = SEVERITY)
	then do;
		if (pass = DO_CONTROL_ARGS)
		then do;
			severity1 = cv_dec_check_ (before (arg, ":"), code);
			if (code ^= 0)
			then
INVALID_SEVERITY_RANGE:
			     call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				"Invalid severity value ""^a"": must be <N> or <N>:<M>", arg);

			if (index (arg, ":") = 0)
			then /* Not a range, just a single number */
			     severity2 = severity1;
			else severity2 = cv_dec_check_ (after (arg, ":"), code);
			if (code ^= 0)
			then goto INVALID_SEVERITY_RANGE;

			call log_match_$add_severity (opt.lmd_ptr, severity1, severity2);
		     end;
	     end;

	else if (really_looking_for = EXPAND_TYPE)
	then do;
		if (pass = DO_CONTROL_ARGS)
		then do;
			call log_expand_select_$add (opt.expand_select_ptr, arg, code);
			if (code ^= 0)
			then call ssu_$abort_line (sci_ptr, code, "Invalid expansion type/modes: ""^a"".", arg);
		     end;
	     end;
	else if really_looking_for = CALL_COMMAND
	then do;
		if (pass = DO_CONTROL_ARGS)
		then do;
			if opt.call_command.ptr ^= null ()
			then free opt_call_command_string;
			if arg ^= ""
			then do;
				opt.call_command.ptr = addr (arg);
				opt.call_command.length = length (arg);
			     end;
			else do;
				opt.call_command.ptr = null ();
				opt.call_command.length = 0;
				opt.call_given_sw = "0"b;
			     end;
		     end;
	     end;
	return;
     end process_looking_for;

two_logs:
     procedure;
	call ssu_$abort_line (sci_ptr, error_table_$too_many_args,
	     "Only one log may be specified, and ^a is the second.", arg);
	return;
     end two_logs;


get_next_arg:
     procedure (P_option);

	declare P_option		 char (*) varying parameter;


	if (arg_idx >= arg_count)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Value missing after ^a", arg);

	arg_idx = arg_idx + 1;
	call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_lth);

	P_option = arg;

	return;
     end get_next_arg;


check_options:
     procedure ();

	declare action_opt		 (7) bit (1) unaligned;

	if (opt.pathname = "") & ^opt.time_given_sw & ^opt.status_sw
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage:^-^a  LogPathname  {-control_args}",
		COMMAND_NAME);

	if (looking_for > 0)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "After ^a", arg);

	string (action_opt) =
	     opt.add_sw || opt.remove_sw || opt.replace_sw || opt.modify_sw || opt.on_sw || opt.off_sw || opt.status_sw;
	if sum (bin (action_opt (*), 1)) > 1
	then call ssu_$abort_line (sci_ptr, 0,
		"Only one of -add, -remove, -replace, -modify, -on, -off, or -status may be given.");

	return;
     end check_options;

     end process_arguments$$find_log_and_action;


adjust_log_message_format:
     procedure (P_doing_what, P_doing_it_with);

	declare P_doing_what	 char (*) parameter;
	declare P_doing_it_with	 char (*) parameter;


	call format_log_message_$adjust (log_message_format_ptr, code);
	if (code = 0)
	then /* All OK */
	     return;

	call ssu_$abort_line (sci_ptr, code, "^a ^a",	/* Hope this identifies the source of error correctly */
	     P_doing_what, P_doing_it_with);		/* There are many possible errors from $adjust */

     end adjust_log_message_format;

/* format: off */
%page; %include log_message;
%page; %include log_message_format;
%page; %include log_read_open_info;
%page; %include monitor_sys_log_info_;
%include sub_err_flags;
        end monitor_sys_log;




		    monitor_sys_log_wakeup_.pl1     08/29/88  0952.0rew 08/29/88  0858.7       84555



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

/* monitor_sys_log_wakeup_.pl1 -- event wakeup handler for monitor_sys_log */
/* format: style2 */

monitor_sys_log_wakeup_:
     procedure;

/**** Created 1984-12, BIM. */
/**** Modified 1985-01-15, BIM: process_id and data_class printing. */


/****^  HISTORY COMMENTS:
  1) change(88-04-28,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29,MR12.2-1093):
      A) Add a "start" control order to restart any I/O interrupted by this
         wakeup handler printing out a message. (phx20587)
                                                   END HISTORY COMMENTS */


	declare P_event_call_info_ptr	 pointer;

%include event_call_info;

	declare cu_$cp		 entry (ptr, fixed bin (21), fixed bin (35));
	declare date_time_$format	 entry (character (*), fixed binary (71), character (*), character (*))
				 returns (character (250) var);
	declare expand_log_message_	 entry (pointer, pointer, pointer, character (*) var, fixed binary (35));
	declare expand_log_message_$append_octal
				 entry (pointer, pointer, fixed binary, character (*) var);
	declare expand_log_message_$append_process_id
				 entry (pointer, pointer, character (*) var);
	declare expand_log_message_$append_data_class
				 entry (pointer, pointer, character (*) var);
	declare format_log_message_$format
				 entry (pointer, pointer, pointer, character (*) var, character (*) var,
				 fixed binary (35));
	declare ioa_$rsnnl		 entry () options (variable);
	declare iox_$control	 entry (ptr, char(*), ptr, fixed bin(35));
	declare iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	declare ipc_$drain_chn	 entry (fixed bin (71), fixed bin (35));
	declare log_expand_select_$test
				 entry (pointer, pointer, bit (1) aligned, pointer);
	declare log_match_$test	 entry (pointer, pointer, character (*) var) returns (bit (1) aligned);
	declare log_read_$next_message entry (pointer, pointer, fixed binary (35));
	declare log_read_$update	 entry (fixed binary (35), pointer, pointer, fixed binary (35));
	declare requote_string_	 entry (character (*)) returns (character (*));
	declare timer_manager_$alarm_wakeup
				 entry (fixed binary (71), bit (2), fixed binary (71));

	declare code		 fixed bin (35);

%include monitor_sys_log_info_;
	declare an_entry_ptr	 pointer;
	declare 1 an_entry		 aligned like monitor_sys_log_array.entry based (an_entry_ptr);
	declare (addr, addwordno, dimension, length, null)
				 builtin;

%include log_message;
%include log_message_format;


timer:
     entry (P_event_call_info_ptr);

	event_call_info_ptr = P_event_call_info_ptr;

	if ^monitor_sys_log_data_.initialized | ^monitor_sys_log_data_.active
	then return;

	call ipc_$drain_chn (monitor_sys_log_data_.wakeup_event_channel, (0));

	monitor_sys_log_array_ptr = monitor_sys_log_data_.log_array_ptr;
	if monitor_sys_log_data_.n_logs_on_timer > 0 & monitor_sys_log_array_ptr ^= null ()
	then call process_logs;

	if monitor_sys_log_data_.active & monitor_sys_log_data_.wakeup_event_channel ^= 0
	then call timer_manager_$alarm_wakeup (monitor_sys_log_data_.wakeup_interval, "11"b,
		monitor_sys_log_data_.wakeup_event_channel);
	return;

process_logs:
     procedure;

	declare lx		 fixed bin;

	do lx = 1 to monitor_sys_log_array.n_entries;
	     an_entry_ptr = addr (monitor_sys_log_array.entry (lx));
	     if an_entry.dir_name ^= ""
	     then if ^an_entry.registered
		then if ^an_entry.inhibited
		     then call process_one_log;
	end;

	return;
     end process_logs;

process_one_log:
     procedure;					/* assumes an_entry_ptr set */
	declare printed_one_message    bit (1) aligned;   /* do "start" control if any message printed from this log. */
	declare process_last_message	 bit (1) aligned;	/* for first message in empty log fencepost -- process the "last" message. */
	declare saved_last_message_ptr pointer;

	process_last_message = "0"b;
	if an_entry.last_message_ptr = null ()
	then do;					/* was empty when we started */
		call log_read_$next_message (an_entry.log_read_ptr, an_entry.last_message_ptr, code);
		if code ^= 0
		then return;			/* Still no entries in the log */
		an_entry.last_sequence = an_entry.last_message_ptr -> log_message.sequence;
						/* okay, consider the first message, and fall down to update */
		process_last_message = "1"b;
	     end;

	call log_read_$update (an_entry.last_sequence, an_entry.log_read_ptr, an_entry.last_message_ptr, code);
	if code ^= 0
	then return;
	printed_one_message = "0"b;			/* remember if any messages were printed. */
	do while (code = 0);
	     saved_last_message_ptr = an_entry.last_message_ptr;
	     if ^process_last_message
	     then /* Normal case */
		call log_read_$next_message (an_entry.log_read_ptr, an_entry.last_message_ptr, code);
	     else do;				/* first message in empty seg is in the last_ vars */
		     saved_last_message_ptr = null ();	/* prev_message to first message in segment is null () */
		     process_last_message = "0"b;	/* only do this ONCE */
		     code = 0;
		end;
	     if an_entry.last_message_ptr = null () | code ^= 0
						/* in process_last_message case this is guaranteed to fail */
	     then an_entry.last_message_ptr = saved_last_message_ptr;
	     else if code = 0
	     then do;
		     an_entry.prev_message_ptr = saved_last_message_ptr;
		     an_entry.last_sequence = an_entry.last_message_ptr -> log_message.sequence;
		     call process_message;
		end;
	end;
          if printed_one_message			/* restart any interrupted I/O. */
	then call iox_$control (an_entry.iocb_ptr, "start", null, code);
	return;

process_message:
     procedure;

	declare output_buffer	 char (5000) varying;
	declare expansion		 char (5000) varying;
	declare expand_this_message	 bit (1) aligned;
	declare expand_mode_ptr	 pointer;

	log_message_ptr = an_entry.last_message_ptr;
	if ^log_match_$test (an_entry.lmd_ptr, log_message_ptr, "")
						/* first, see if we can toss this without any work at all */
	then return;
	if ^an_entry.interpret_sw
	then /* If not interpreting, then definitely not */
	     expand_this_message = "0"b;
	else if (dimension (log_message.data, 1) = 0)
	then /* And, if no data, also definitely not */
	     expand_this_message = "0"b;
	else if (an_entry.expand_select_ptr = null ())
	then do;					/* But if we are interpreting, and no classes were */
		expand_this_message = "1"b;		/* asked for, we do expand this one's data */
		expand_mode_ptr = null ();		/* But, obviously, there were no expand modes asked for */
	     end;
	else call log_expand_select_$test
		/* Otherwise, we ask the selector */ (an_entry.expand_select_ptr, log_message_ptr,
		expand_this_message, expand_mode_ptr);

	if expand_this_message
	then call expand_log_message_ (an_entry.format_ptr, log_message_ptr, expand_mode_ptr, expansion, (0));
	else expansion = "";			/* This one has nothing for the formatter */
	if ^log_match_$test (an_entry.lmd_ptr, log_message_ptr, expansion)
	then return;

	if an_entry.octal_sw
	then call expand_log_message_$append_octal (an_entry.format_ptr, addr (log_message.data),
		(log_message.data_lth), expansion);

	if an_entry.process_id_sw
	then call expand_log_message_$append_process_id (an_entry.format_ptr, log_message_ptr, expansion);
	if an_entry.data_class_sw
	then call expand_log_message_$append_data_class (an_entry.format_ptr, log_message_ptr, expansion);

	if an_entry.call_command.ptr ^= null ()
	then call process_call;
	else call process_print;

	return;

process_print:
     procedure;

	call format_log_message_$format (an_entry.format_ptr, log_message_ptr, an_entry.prev_message_ptr, expansion,
	     output_buffer, (0));

	call iox_$put_chars (an_entry.iocb_ptr, addwordno (addr (output_buffer), 1), length (output_buffer), (0));
	printed_one_message = "1"b;
	return;
     end process_print;

process_call:
     procedure options (non_quick);

	declare requoted_buffer	 char (5000) varying;
	declare command_line_buffer	 char (6000) varying;
						/* has got to be big enough */
	declare dt_string		 char (100) varying;
	declare call_command_string	 char (an_entry.call_command.length) based (an_entry.call_command.ptr);

/**** This needs data expansion support ... */

	log_message_ptr = an_entry.last_message_ptr;
	requoted_buffer = requote_string_ (log_message.text);
	dt_string = requote_string_ (date_time_$format ("iso_long_date_time", (log_message.time), "", ""));
	command_line_buffer = "";
	call ioa_$rsnnl ("^a ^a ^a ^d ^d ^a^[ ^a ^a^]", command_line_buffer, (0), call_command_string,
	     an_entry.format_ptr -> log_message_format.prefix, dt_string, log_message.sequence, log_message.severity,
	     requoted_buffer, log_message.data_class_lth > 0, log_message.data_class,
	     """""" /* will be expanded text */);

	call cu_$cp (addwordno (addr (command_line_buffer), 1), length (command_line_buffer), (0));
	return;
     end process_call;

     end process_message;
     end process_one_log;
     end monitor_sys_log_wakeup_;




		    move_log_segments.pl1           04/09/85  1353.7r w 04/08/85  1132.9      114678



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

/* *      MOVE_LOG_SEGMENTS
   *
   *      An interim solution to the problem of migrating log segments from one
   *      directory to the next.  Someday, this should be done to individual
   *      messages, not just whole segments, but since log_migrate_ doesn't work
   *      yet, this will have to do.
   *
   *      84-10-31, W. Olin Sibert: Initial coding, mostly out of log_list_history_
   *	85-03-07, Steve Herbst: Added -force/-no_force, namedup handling.
   *	85-03-21, Steve Herbst: Fixed bug that saw relative time cutoff
   *		such as -2days as a control argument.
   */

declare   code fixed bin (35);
declare   system_area_ptr pointer;
declare   system_area area based (system_area_ptr);
declare   sort_pointers_ptr pointer;
declare   next_log_ptr pointer;
declare   this_log_ptr pointer;
declare   segment_count fixed bin;
declare   move_count fixed bin;
declare	force_sw bit (1);

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   log_dir char (168);
declare   log_name char (32);
declare   migration_dir char (168);
declare   cutoff fixed bin (71);

declare   absolute_pathname_ entry (char (*), char (*), fixed bin (35));
declare   com_err_ entry options (variable);
declare	error_table_$badopt fixed bin (35) external static;
declare   error_table_$no_w_permission fixed bin (35) external static;

declare   convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
declare   copy_ entry (pointer);
declare   cu_$arg_count entry (fixed bin, fixed bin (35));
declare   cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
declare   expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
declare   get_system_free_area_ entry () returns (pointer);
declare   hcs_$fs_get_mode entry (pointer, fixed bin (5), fixed bin (35));
declare   hcs_$star_ entry (char (*), char (*), fixed bin (2), pointer, fixed bin, pointer, pointer, fixed bin (35));
declare   hcs_$terminate_noname entry (pointer, fixed bin (35));
declare   ioa_ entry options (variable);
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	pathname_ entry (char(*), char(*)) returns(char(168));
declare   sort_items_$general entry (pointer, entry);

declare	index builtin;

declare   WHOAMI char (32) internal static options (constant) init ("move_log_segments");

declare   cleanup condition;

/*  */

          star_entry_ptr = null ();                         /* Initialize for cleanup handler */
          star_names_ptr = null ();                         /* Initialize for cleanup handler */
          sort_pointers_ptr = null ();                      /* Initialize for cleanup handler */
          next_log_ptr = null ();
          this_log_ptr = null ();
          system_area_ptr = get_system_free_area_ ();

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

          call process_arguments ();

          call list_directory ();

          call move_segments ();

          call ioa_ ("^a: ^[No log segments moved.^;Moved ^d log segment^[s^] to ^a.^]",
               WHOAMI, (move_count = 0), move_count, (move_count ^= 1), migration_dir);

MAIN_RETURN:
          call clean_up ();
          return;

/*  */

list_directory:
     procedure ();

declare   entry_idx fixed bin;
declare   log_starname char (32);


          log_starname = log_name_$starname (log_name);

          call hcs_$star_ (log_dir, log_starname, star_BRANCHES_ONLY, system_area_ptr,
               star_entry_count, star_entry_ptr, star_names_ptr, code);

          if (code ^= 0) then do;
               call com_err_ (code, WHOAMI, "Listing ^a>^a", log_dir, log_starname);
               goto MAIN_RETURN;
               end;

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

          segment_count = 0;
          move_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 < 2) then do;
               call com_err_ (0, WHOAMI,
                    "At least two log segments must be present in ^a in order to migrate one.",
		     pathname_ (log_dir, log_name));
               goto MAIN_RETURN;
               end;

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

          end list_directory;

/*  */

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;

/*  */

move_segments:
     procedure ();

declare   segment_idx fixed bin;
declare   this_ename char (32);
declare   next_ename char (32);
declare   suffix_time fixed bin (71);

declare 1 copy_opt aligned like copy_options automatic;
declare 1 one_star_entry aligned based like star_entries;


          unspec (copy_opt) = ""b;
          copy_opt.version = COPY_OPTIONS_VERSION_1;
          copy_opt.caller_name = WHOAMI;
          copy_opt.source_dir = log_dir;
          copy_opt.target_dir = migration_dir;
          copy_opt.force = force_sw;
          copy_opt.delete = "1"b;

          copy_opt.copy_items.names = "1"b;
          copy_opt.copy_items.acl = "1"b;
          copy_opt.copy_items.ring_brackets = "1"b;
          copy_opt.copy_items.max_length = "1"b;
          copy_opt.copy_items.safety_switch = "1"b;

          do segment_idx = segment_count to 2 by -1;        /* Do NOT move the first one */
               this_ename = star_names (sort_pointers.ptr (segment_idx) -> one_star_entry.nindex);
               next_ename = star_names (sort_pointers.ptr (segment_idx - 1) -> one_star_entry.nindex);
               suffix_time = log_name_$time (this_ename);

               if (suffix_time > cutoff) then               /* All finished */
                    return;

               call initiate_log (next_ename, next_log_ptr); /* Get the next log so we can set its history */

               if (segment_idx = segment_count) then do;    /* If first moved, set its history dir, too */
                    call initiate_log (this_ename, this_log_ptr);
                    this_log_ptr -> log_segment.previous_log_dir = migration_dir;
                    call hcs_$terminate_noname (this_log_ptr, (0));
                    end;

               copy_opt.source_name = this_ename;
               copy_opt.target_name = this_ename;

               call ioa_ ("^a: Moving ^a>^a", WHOAMI, log_dir, this_ename);

               call copy_ (addr (copy_opt));

               if copy_opt.target_err_switch then
                    return;
               else move_count = move_count + 1;

               next_log_ptr -> log_segment.previous_log_dir = migration_dir;
               call hcs_$terminate_noname (next_log_ptr, (0));
               end;

          return;
          end move_segments;

/*  */

initiate_log:
     procedure (P_name, P_ptr);

declare   P_name char (*) parameter;
declare   P_ptr pointer parameter;

declare   log_mode fixed bin (5);


          call log_initiate_ (log_dir, P_name, 10, P_ptr, code);

          if (code ^= 0) then do;
               call com_err_ (code, WHOAMI, "Cannot initiate ^a>^a", log_dir, P_name);
               goto MAIN_RETURN;
               end;

          call hcs_$fs_get_mode (P_ptr, log_mode, code);
          if (code = 0) then
               if (log_mode ^= RW_ACCESS_BIN) & (log_mode ^= REW_ACCESS_BIN) then
                    code = error_table_$no_w_permission;

          if (code ^= 0) then do;
               call com_err_ (code, WHOAMI, "^a>^a", log_dir, P_name);
               goto MAIN_RETURN;
               end;

          return;
          end initiate_log;

/*  */

process_arguments:
     procedure ();

declare   arg_ptr pointer;
declare   arg_lth fixed bin (21);
declare   arg char (arg_lth) based (arg_ptr);
declare   arg_count fixed bin;
declare   arg_idx fixed bin;
declare  (got_log_name, got_from_dir, got_to_dir, got_time_cutoff) bit (1);

          call cu_$arg_count (arg_count, code);
          if (arg_count < 4) then do;
USAGE:         call com_err_ (0, WHOAMI, "Usage:^-^a LogName FromDir ToDir TimeCutoff {-control_args}", WHOAMI);
               goto MAIN_RETURN;
               end;

	force_sw = "0"b;
	got_log_name, got_from_dir, got_to_dir, got_time_cutoff = "0"b;

	do arg_idx = 1 to arg_count;

	     call cu_$arg_ptr (arg_idx, arg_ptr, arg_lth, (0));

	     if index (arg, "-") = 1 then do;
		if got_to_dir & ^got_time_cutoff then do;
		     call convert_date_to_binary_ (arg, cutoff, code);
		     if code = 0 then do;		/* relative time, not a control arg */
			got_time_cutoff = "1"b;
			go to END_ARG_LOOP;
			end;
		     end;
		if arg = "-force" | arg = "-fc" then force_sw = "1"b;
		else if arg = "-no_force" | arg = "-nfc" then force_sw = "0"b;
		else do;
		     call com_err_ (error_table_$badopt, WHOAMI, "^a", arg);
		     go to MAIN_RETURN;
		     end;
		end;

	     else if ^got_log_name then do;
		got_log_name = "1"b;
		log_name = arg;
		end;

	     else if ^got_from_dir then do;
		got_from_dir = "1"b;
		call absolute_pathname_ (arg, log_dir, code);
		if code ^= 0 then do;
		     call com_err_ (code, WHOAMI, "Directory to move from: ^a", arg);
		     go to MAIN_RETURN;
		     end;
		end;

	     else if ^got_to_dir then do;
		got_to_dir = "1"b;
		call absolute_pathname_ (arg, migration_dir, code);
		if code ^= 0 then do;
		     call com_err_ (code, WHOAMI, "Directory to move to: ^a", arg);
		     go to MAIN_RETURN;
		     end;
		end;

	     else if ^got_time_cutoff then do;
		got_time_cutoff = "1"b;
		call convert_date_to_binary_ (arg, cutoff, code);
		if code ^= 0 then do;
		     call com_err_ (code, WHOAMI, "Cutoff time ^a", arg);
		     go to MAIN_RETURN;
		     end;
		end;

	     else go to USAGE;
END_ARG_LOOP:
	     end;

	if ^got_time_cutoff then go to USAGE;

          return;

          end process_arguments;

/*  */

clean_up:
     procedure ();

declare   based_word 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 -> based_word in (system_area);
          if (star_names_ptr ^= null ()) then
               free star_names_ptr -> based_word in (system_area);
          if (sort_pointers_ptr ^= null ()) then
               free sort_pointers_ptr -> based_word in (system_area);
          if (next_log_ptr ^= null ()) then
               call hcs_$terminate_noname (next_log_ptr, (0));

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

          return;
          end clean_up;

%page; %include star_structures;
%page; %include copy_options;
%page; %include copy_flags;
%page; %include access_mode_values;
%page; %include log_segment;

          end move_log_segments;




		    old_syserr_log_util_.pl1        01/26/85  1312.8rew 01/25/85  0847.1      230886



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


/* SYSERR_LOG_UTIL_ - Procedure to search and read the "syserr log" composed of a ring 4 vfile_ in >system_control_1
   and a ring 0 threaded list */

/* Written late 1975 by Lee Scheffler */
/* Modified January 1976 by Larry Johnson to fix some bugs */
/* Modified April 1976 by Larry Johnson to fix some bugs */
/* Modified October 1982 by E. N. Kittlitz to add open_path, trim_path */
/* 84-10-04, WOS: Converted to old_syserr_log_util_ for new logging migration */

/* format: style4 */
old_syserr_log_util_: proc ();

/* Entries */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  audit_gate_$copy_syserr_log entry (bit (18) aligned, pointer, fixed bin (24), fixed bin (24));
dcl  delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  get_pdir_ entry () returns (char (168));
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35));
dcl  iox_$attach_ioname entry (char (*), pointer, char (*), fixed bin (35));
dcl  iox_$close entry (pointer, fixed bin (35));
dcl  iox_$control entry (pointer, char (*), pointer, fixed bin (35));
dcl  iox_$delete_record entry (pointer, fixed bin (35));
dcl  iox_$detach_iocb entry (pointer, fixed bin (35));
dcl  iox_$find_iocb entry (char (*), pointer, fixed bin (35));
dcl  iox_$open entry (pointer, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$position entry (pointer, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$read_key entry (pointer, char (256) varying, fixed bin (21), fixed bin (35));
dcl  iox_$read_record entry (pointer, pointer, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$seek_key entry (pointer, char (256) varying, fixed bin, fixed bin (35));
dcl  iox_$write_record entry (pointer, pointer, fixed bin (21), fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));
dcl  sub_err_ entry () options (variable);
dcl  unique_bits_ entry returns (bit (71));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

/* Builtin */

declare  (addr, addrel, bin, divide, fixed, null, ptr, rel, rtrim, substr, unspec) builtin;

/* Status codes */

dcl  error_table_$bad_arg fixed bin (35) external;
dcl  error_table_$end_of_info fixed bin (35) external;
dcl  error_table_$file_busy fixed bin (35) external;
dcl  error_table_$key_duplication fixed bin (35) external;
dcl  error_table_$key_order fixed bin (35) external;
dcl  error_table_$moderr fixed bin (35) external;
dcl  error_table_$no_record fixed bin (35) external;
dcl  error_table_$not_detached fixed bin (35) external;
dcl  error_table_$not_open fixed bin (35) external;

/* Constants */

dcl  R0_VFILE char (13) internal static initial ("r0_syserr_log");
dcl  R0_SW char (13) internal static initial ("r0_syserr_i/o");
dcl  R4_SW char (13) internal static initial ("r4_syserr_i/o");
dcl  R4_PATH char (168) internal static initial (">system_control_1>perm_syserr_log");
dcl  (NO init ("0"b), YES init ("1"b)) bit (1) internal static;
dcl  (KSI initial (8), KSO initial (9), KSU initial (10)) fixed bin internal static; /* Opening modes */
dcl  (EOF initial (+1), BOF initial (-1), SKIP initial (0)) fixed bin internal static; /* For iox_$position */


/* Statics */

dcl  iop (2) pointer internal static initial ((2) null ()); /* iop (1) -> IOCB (r0 log in process dir) */
						/* iop (2) -> IOCB (r4 log in >sc1) */
dcl  curlog fixed bin (2) internal static initial (0);	/* index into iop of log piece
						   containing "current messagee" */
dcl  OPEN bit (1) aligned internal static initial ("0"b);	/* ON iff log is open */

/* Miscellaneous */

dcl  r0_vfile char (32) internal static;		/* Unique name of vfile in process dir holding r0 log */
dcl  r0_vpath char (168) varying;			/* Pathnaame of same */
dcl  r4_dir char (168);
dcl  r4_entry char (32);
dcl  r4_path char (168);				/* Pathname of ring 4 perm-syserr-log vfile */
dcl  ec fixed bin (35);				/* Ubiquitous status code */
dcl  log_len fixed bin (24);				/* Length of ring 0 syserr log */
dcl  key char (256) varying;				/* iox_ record key */
dcl  keybits bit (9 * 16);				/* Used to convert fixed bins to char keys */
dcl  keychars char (16) based (addr (keybits));
dcl  (off, nextoff, prevoff) bit (18);			/* Used in searching r0 syserr log */
dcl  time fixed bin (71);				/* Message time */
dcl  linkage_error condition;				/* Signalled when user has no access to r0 log */
dcl  key_dup bit (1) aligned;
dcl  seg_array (1) ptr;				/* array of pointers for temp seg manager */

/* Entry to attach and open the "syserr log" for searching */
/* This entry first opens the ring 4 syserr log vfile_, creates a virgin temporary vfile_
   in the process directory, copies the ring 0 syserr log into a temp in the process directory,
   copies all messages from the ring 0 log not already in the ring 4 log into the temp vfile,
   then views the two vfiles as one "log" */

old_syserr_log_util_$open: entry (access, ec);

dcl  access bit (36) aligned parameter;			/* "1X"b if ring 0 log is available
						   "X1"b if ring 4 log is available */
dcl  r4_ec fixed bin (35);				/* Status code for ring 4 log opening */

	r4_path = R4_PATH;
	go to open_join;

old_syserr_log_util_$open_path: entry (a_open_path, access, ec);

dcl  a_open_path char (*);				/* pathname of perm-syserr-log */

	r4_path = a_open_path;			/* user tells us where */
	if r4_path = "" then			/* oops, got lazy */
	     r4_path = R4_PATH;			/* use the default */

open_join:
	OPEN = NO;				/* Let's get one thing straight: WE ARE NOT OPEN YET */
	curlog = 0;				/* Also, we have not yet established our position yet */
	access = "00"b;				/* In case we abort */
	iop (1), iop (2) = null ();			/* Make sure we redo these pointers on every open */

	call ATTACH_AND_OPEN ((R4_SW), ("vfile_ " || rtrim (r4_path)), iop (2), (KSI), r4_ec); /* Open the ring 4 log for
						   keyed-sequential input, no extension */
	if r4_ec = 0 then access = access | "01"b;	/* Ring 4 log is accessible */
	else do;
	     ec = r4_ec;				/* In case we return now */
	     call CLOSE_AND_DETACH (iop (2), 0);	/* Close it if we did open it */
	     if r4_ec = error_table_$file_busy then return; /* A put-off: user has access, but its busy */
	end;

get_r0_log:
	slog_ptr = null ();				/* In case of abort */
	r0_vfile = R0_VFILE || "." || unique_chars_ (unique_bits_ ()); /* Get unique name for temp seg */
	r0_vpath = rtrim (get_pdir_ ()) || ">" || r0_vfile;

	call ATTACH_AND_OPEN ((R0_SW), "vfile_ " || r0_vpath || " -extend", iop (1), (KSO), ec);
						/* Open previously non-existent vfile_
						   in process dir. (Do this first to make sure we have room) */
	if ec ^= 0 then go to r4_only;

	call get_temp_segments_ ("old_syserr_log_util_", seg_array, ec); /* get a temp seg */
	if ec ^= 0 then go to r4_only;
	slog_ptr = seg_array (1);			/* this will be used to reference log */

	on linkage_error begin;
		log_len = 0;			/* no data */
		go to no_r0_access;
	     end;

	call audit_gate_$copy_syserr_log ("0"b, slog_ptr, fixed (rel (addr (slog.buffer)), 17), log_len);
						/* Copy header of ring 0 log from ring 0 */
no_r0_access:
	revert linkage_error;
	if log_len = 0 then do;			/* Don't know why, but no luck */
	     ec = error_table_$moderr;
	     go to r4_only;
	end;

	time = 0;
	if iop (2) ^= null () then do;		/* If we have  the ring 4 log, get time of last mess */

	     call iox_$position (iop (2), (EOF), 0, ec);	/* Position to end-of-file in ring 4 log */
	     if ec ^= 0 then do;
r0_only:
		call CLOSE_AND_DETACH (iop (2), 0);	/* Problems, punt */
		go to copy_whole_r0_log;
	     end;

	     call iox_$position (iop (2), (SKIP), -1, ec);/* Move to last msg in r4 log */
	     if ec ^= 0 then go to r0_only;

	     call iox_$read_key (iop (2), key, 0, ec);	/* Read its key */
	     if ec ^= 0 then go to r0_only;

	     call DECODE_KEY (key, time, 0);		/* Pull msg time out of key */
	end;

	if time = 0 then go to copy_whole_r0_log;	/* Need whole thing */

	if slog.last_copied = slog.last then do;	/* No need to do anything */
	     access = access | "10"b;			/* R0 log accessiblke, but null */
	     go to r4_only;
	end;

	if slog.last_copied = "0"b then do;		/* Need it all */
copy_whole_r0_log:
	     call audit_gate_$copy_syserr_log ("0"b, slog_ptr, slog.len + 4 * bin (rel (addr (slog.buffer))), log_len);

	     if time = 0 then do;			/* No r4 log */
		off = slog.first;
		prevoff = "0"b;
		go to fill_r0_vfile;		/* Fill in vfile */
	     end;

	     else do;				/* We have some searching to do */
		off = slog.last;
		nextoff = "0"b;

		do while (off ^= "0"b & nextoff ^= slog.first); /* Cover both intermediate threading states */
		     smess_ptr = addrel (slog_ptr, off);
		     if smess.time <= time		/* Found overlap point between both logs */
		     then go to found_msg;
		     nextoff = off;
		     off = smess.prev;
		end;
found_msg:
		prevoff = off;
		off = nextoff;
		go to fill_r0_vfile;
	     end;
	end;

	if slog.last_copied < slog.last then do;	/* Unwrapped, partially copied log */
	     call audit_gate_$copy_syserr_log (slog.last_copied, ptr (slog_ptr, slog.last_copied),
		4 * (bin (slog.last) - bin (slog.last_copied) + 512), log_len); /* 512 extra words to get last message for sure */
set_off:
	     if time ^= ptr (slog_ptr, slog.last_copied) -> smess.time
	     then go to copy_whole_r0_log;		/* Oh well. We tried */

	     off = rel (addr (ptr (slog_ptr, slog.last_copied) -> smess.next_smess)); /* First message for vfile */
						/* Since we are only going forward,
						   there is no need to make slog.first
						   and the first message back pointer
						   consistent */
	     prevoff = "0"b;
	     go to fill_r0_vfile;
	end;

	else do;					/* Wrapped log, have to copy two pieces */
	     call audit_gate_$copy_syserr_log (slog.last_copied, ptr (slog_ptr, slog.last_copied),
		4 * (bin (rel (addr (slog.end_point))) - bin (slog.last_copied)), log_len); /* Copy bottom piece */
	     call audit_gate_$copy_syserr_log (rel (addr (slog.buffer)), addr (slog.buffer),
		4 * (bin (slog.last) - bin (rel (addr (slog.buffer))) + 512), log_len);
	     go to set_off;
	end;


fill_r0_vfile:
	do while (off ^= "0"b & prevoff ^= slog.last);	/* Cover both intermediate threading cases */

	     smess_ptr = addrel (slog_ptr, off);
	     key_dup = "0"b;			/* No key duplication yet */
compute_key:
	     keybits = unspec (smess.time) || unspec (smess.seq_num) || unspec (smess.code); /* Concoct key for insertion */
	     key = keychars;			/* Set into the right size variable */
set_key:
	     call iox_$seek_key (iop (1), key, 0, ec);	/* Set key for insertion */
	     if ec = error_table_$key_order then do;	/* Keys not in order (clock messed up?) */
		call iox_$close (iop (1), ec);	/* Close it... */
		if ec ^= 0 then go to r4_only;
		call iox_$open (iop (1), (KSU), "0"b, ec); /* Open for update, so keys can be out of order */
		if ec ^= 0 then go to r4_only;
		go to set_key;
	     end;
	     if ec = error_table_$key_duplication then do;
		if key_dup then go to next_mess;	/* Try once, then give up */
		key_dup = "1"b;
		smess.time = smess.time + 1;		/* Change key enough to get in */
		go to compute_key;
	     end;
	     if ec ^= error_table_$no_record then go to r4_only; /* Shouldn't be there yet */

	     call iox_$write_record (iop (1), addr (smess.seq_num),
		4 * (bin (rel (addr (smess.next_smess))) - bin (rel (addr (smess.seq_num)))), ec);
						/* Record for vfile log does not include threading */
	     if ec ^= 0 then go to r4_only;
next_mess:
	     prevoff = off;
	     off = smess.next;
	end;

	call CLOSE_AND_DETACH (iop (1), 0);		/* Close and re-open for efficiency */

	call ATTACH_AND_OPEN ((R0_SW), "vfile_ " || r0_vpath, iop (1), (KSI), ec);
	if ec = 0 then access = access | "10"b;		/* R0 log is available */
	else
r4_only:
	     call CLOSE_R0_LOG (0);			/* Come here if r0 log not accessible, or null */
	if slog_ptr ^= null then do;			/* if temp segment gotten */
	     slog_ptr = null;
	     call release_temp_segments_ ("old_syserr_log_util_", seg_array, 0);
	end;
	if ec = 0 then if iop (2) = null then ec = r4_ec; /* if ring0 ok, return possible ring4 error code */
	OPEN = (iop (1) ^= null) | (iop (2) ^= null);	/* open only if at least 1 iocb is ok */
	return;

/* Entry closes up shop after all searching/reading */

old_syserr_log_util_$close: entry (ec);

	if ^OPEN then do;
	     ec = error_table_$not_open;
	     return;
	end;
	OPEN = NO;				/* No longer there */

	if iop (2) ^= null () then call CLOSE_AND_DETACH (iop (2), 0); /* Close and detach ring 4 log */

	if iop (1) ^= null () then call CLOSE_R0_LOG (0); /* Close, detach, and delete r0 vfile */

	curlog = 0;				/* Haven't got a position any more */
	ec = 0;

	return;

/* Entry to trim back the ring  4 syserr log */

old_syserr_log_util_$trim: entry (ttime, ec);

dcl  ttime fixed bin (71) parameter;			/* Trim time */
dcl  iocbp pointer;					/* Points to I/O control block for ring 4 log */
dcl  deltime fixed bin (71);

	r4_path = R4_PATH;
	go to trim_join;

old_syserr_log_util_$trim_path: entry (a_trim_path, ttime, ec);

dcl  a_trim_path char (*);

	r4_path = a_trim_path;			/* user tells us where */
	if r4_path = "" then			/* oops, got lazy */
	     r4_path = R4_PATH;			/* use the default */

trim_join:
	call expand_pathname_ (r4_path, r4_dir, r4_entry, ec);
	if ec ^= 0 then
	     call sub_err_ (ec, "old_syserr_log_util_", ACTION_CANT_RESTART, null (), (0), "Unexpected error with path ^a.", r4_path);
	call hcs_$set_safety_sw (r4_dir, r4_entry, "0"b, ec); /* Have to turn off safety switch */
	if ec ^= 0 then return;			/* No access probably */

	call ATTACH_AND_OPEN ((R4_SW), ("vfile_ " || rtrim (r4_path)), iocbp, (KSU), ec); /* Open permanent log for update */
	if ec ^= 0 then go to trim_done;

/* before deleting any records, check to see if the break will leave an "=" as the first message.
   If so, adjust the break slightly */

	begin;

dcl  buffer (512) bit (36) aligned;			/* read messages here */

	     deltime = ttime;			/* default break time is time given */
	     syserr_msgp = addr (buffer);
	     seek_info.relation = 1;			/* set up seek head order */
	     seek_info.nchars = 8;
	     unspec (seek_info.search_key) = unspec (ttime);
	     call iox_$control (iocbp, "seek_head", addr (seek_info), ec);
	     if ec ^= 0 then go to trim_position;	/* give up */
trim_backup:
	     call iox_$read_record (iocbp, syserr_msgp, 2048, (0), ec);
	     if ec ^= 0 then go to trim_position;
	     if syserr_msg.text ^= "=" then do;		/* found good break */
		deltime = syserr_msg.time;
		go to trim_position;
	     end;
	     call iox_$position (iocbp, 0, -2, ec);	/* back to previous record */
	     if ec = 0 then go to trim_backup;
	     if ec ^= error_table_$end_of_info then go to trim_position;
	     call iox_$control (iocbp, "seek_head", addr (seek_info), ec); /* back to origional break */
	     if ec ^= 0 then go to trim_position;
trim_forward:
	     call iox_$read_record (iocbp, syserr_msgp, 2048, (0), ec); /* read forward for break */
	     if ec ^= 0 then go to trim_position;
	     if syserr_msg.text ^= "=" then do;
		deltime = syserr_msg.time;
		go to trim_position;
	     end;
	     else go to trim_forward;
	end;

/* now ready to delete */

trim_position:
	call iox_$position (iocbp, -1, 0, ec);
	if ec ^= 0 then go to trim_done;

trim_read_key:
	call iox_$read_key (iocbp, key, 0 /* don't care */, ec);
	if ec ^= 0 then do;
	     if ec = error_table_$end_of_info then ec = 0;/* We are done */
	     go to trim_done;
	end;

	call DECODE_KEY (key, time, 0);
	if deltime <= time				/* If msg time later than trim time we are done */
	then go to trim_done;

	call iox_$delete_record (iocbp, ec);		/* ZAP */
	if ec ^= 0 then go to trim_done;

	go to trim_read_key;

trim_done:
	call hcs_$set_safety_sw (r4_dir, r4_entry, "1"b, 0); /* Turn safety switch back on */

	call CLOSE_AND_DETACH (iocbp, 0);

	return;

/* Entry searches for the first syserr message logged after a given time */

old_syserr_log_util_$search: entry (search_time, rtime, rseq, ec);

dcl  search_time fixed bin (71) parameter;		/* Time for searching, in microseconds */
dcl  rtime fixed bin (71) parameter;			/* Logging time of message found */
dcl  rseq fixed bin (35) parameter;			/* Sequence number of message found */

dcl  1 seek_info aligned,				/* Structure for "seek_head" control call */
       2 relation fixed bin,				/* Search for mess-time >= search_time */
       2 nchars fixed bin,				/* unspec (fixed bin (71)) is 8 chars */
       2 search_key char (8);				/* Actual key used */

	rtime = -1;				/* In case of abort */
	rseq = -1;

	if ^OPEN then do;
not_open:	     ec = error_table_$not_open;
	     return;
	end;

	if search_time = 0 then do;			/* Special value, search to BOF */
	     if iop (2) = null () then curlog = 1;	/* Nor r4 log, give r0 log */
	     else curlog = 2;
	     call iox_$position (iop (curlog), (BOF), 0, 0); /* Position to  first (oldest) message */
	     go to search_get_time;
	end;

	if search_time = -1 then do;			/* Special value, search to EOF */
eof:
	     if iop (1) = null () then curlog = 2;	/* Nor r0 log, go to r4 log */
	     else curlog = 1;
	     call iox_$position (iop (curlog), (EOF), 0, 0); /* Move to end-of-file */
	     call iox_$position (iop (curlog), (SKIP), -1, 0); /* Move back one to last message */
	     go to search_get_time;
	end;

	if search_time < -1 then do;			/* What do you think this is? A time machine? */
	     ec = error_table_$bad_arg;
	     return;
	end;

	seek_info.relation = 1;			/* head >= search_key */
	seek_info.nchars = 8;			/* To save prologue */
	substr (unspec (seek_info.search_key), 1, 72) = unspec (search_time); /* fb(71) time is 8 chars */

	do curlog = 2, 1;				/* Try r4 log first */
	     if iop (curlog) ^= null then do;
		call iox_$control (iop (curlog), "seek_head", addr (seek_info), ec);
		if ec = 0 then go to search_get_time;
	     end;
	end;
	go to eof;				/* Not in either log, return last message */

search_get_time:
	call iox_$read_key (iop (curlog), key, 0, ec);	/* Read the key of the message found */
	if ec ^= 0 then return;
get_time:
	call DECODE_KEY (key, rtime, rseq);		/* Decode into its component parts */

	return;

/* Entry positions n messages forward or backward, crossing logs as necessary */

old_syserr_log_util_$position: entry (n, rtime, rseq, ec);

dcl  n fixed bin (21) parameter;			/* No of messages forward (n>_0) or back (n<0) to move */
dcl  moven fixed bin (21);
dcl  move fixed bin;

dcl  1 iox_status aligned,				/* Structure returned by iox_$control "error_status" */
       2 version fixed bin,				/* vfile version number */
       2 type fixed bin,				/* Type of operation this is status for */
       2 to_move fixed bin,				/* How many records we wanted to position */
       2 moved fixed bin;				/* How many records we actually positioned (signed) */

	rtime = -1;				/* In case of abort */
	rseq = -1;

	if ^OPEN then go to not_open;

	if curlog = 0 then do;			/* No call to search yet */
	     ec = error_table_$no_record;
	     return;
	end;

	moven = n;
position:
	if moven = 0 then go to pos_get_time;		/* No work to do */
	call iox_$position (iop (curlog), (SKIP), moven, ec); /* Position in current log */
	if ec = error_table_$end_of_info then do;	/* Ooops! Ran off end */
	     iox_status.version = 1;
	     call iox_$control (iop (curlog), "error_status", addr (iox_status), ec); /* Find out how much we missed by */
	     if ec ^= 0 then return;

	     moven = n - iox_status.moved;		/* Correct for overrun */
	     if n > 0 & curlog = 2 & iop (1) ^= null () then do; /* Have to switch to r0 piece */
switch_to_r0:
		curlog = 1;
		move = BOF;
	     end;

	     else if n < 0 & curlog = 1 & iop (2) ^= null then do; /* Have to switch to r4 piece */
		curlog = 2;
		move = EOF;
	     end;

	     else do;
		ec = error_table_$end_of_info;
		return;
	     end;

	     call iox_$position (iop (curlog), move, 0, ec); /* Move to start or end of other piece */
	     if ec ^= 0 then return;

	     go to position;
	end;

	if ec ^= 0 then return;			/* Don't know what's wrong */
pos_get_time:
	call iox_$read_key (iop (curlog), key, 0, ec);	/* See if this is a real record or EOF */
	if ec = error_table_$end_of_info		/* Moved fwd to EOF */
	then if curlog = 2				/* If in ring 4 piece */
	     then do;				/* See if we can/should switch log pieces */
		if iop (1) = null () then return;	/* No r0 piece, we at end */
		moven = 0;			/* No more moving to do */
		go to switch_to_r0;
	     end;
	     else do;				/* curlog = 1; we are in ring 0 piece */
		call iox_$position (iop (curlog), (SKIP), -1, ec); /* Move back one to last real record */
		if ec ^= 0 then return;		/* I give up */
		go to pos_get_time;
	     end;

	if ec = 0 then go to get_time;		/* Success at last */
	else return;

/* Entry reads the current syserr message, updates the current message to the next message, and switches logs if necessary */

old_syserr_log_util_$read: entry (bufp, bufl, messl, ec);

dcl  bufp pointer parameter;				/* Points to caller-supplied buffer */
dcl  bufl fixed bin (21) parameter;			/* Length of caller-supplied buffer */
dcl  messl fixed bin (21) parameter;			/* Actual length of this message, even if >buffl */
dcl  retlen fixed bin (21);				/* length in chars returned by iox */

	if ^OPEN then go to not_open;

	if curlog = 0 then do;			/* No call to search yet */
	     ec = error_table_$no_record;
	     messl = 0;
	     return;
	end;

read:
	call iox_$read_record (iop (curlog), bufp, 4 * bufl, retlen, ec); /* Read the record */
	if ec = error_table_$end_of_info		/* If at end of this vfile_ ... */
	then if curlog = 2				/* Cross boundaries */
	     then if iop (1) ^= null () then do;
		     curlog = 1;			/* Switch to ring 0 piece */
		     call iox_$position (iop (1), (BOF), 0, ec); /* Position to first message in ring 0 piece */
		     go to read;
		end;
	messl = divide (retlen, 4, 21, 0);		/* compute length in words */

	return;

/* Entry returns a status structure, currently including only a version number constant */

old_syserr_log_util_$status: entry (status_p, ec);

dcl  status_p pointer parameter;			/* Points to user-supplied structure */

dcl  1 slu_status aligned based (status_p),		/* Ain't much to it yet */
       2 version fixed bin;

	slu_status.version = 1;
	ec = 0;
	return;

/* Internal procedure to attach and open a log with a given attach description and opening  mode */

ATTACH_AND_OPEN: proc (switch, atd, iocbp, omode, ec);

dcl  switch char (*) parameter;			/* Switch being attached */
dcl  atd char (*) parameter;				/* Attach description */
dcl  iocbp pointer parameter;				/* Pointer to created io control block */
dcl  omode fixed bin parameter;			/* Opening mode */
dcl  ec fixed bin (35) parameter;			/* Status code */
dcl  ec1 fixed bin (35);

attach:
	call iox_$attach_ioname (switch, iocbp, atd, ec);
	if ec ^= 0 then do;				/* Somebody forgot to turn out the light */
	     if ec = error_table_$not_detached then do;
		call iox_$find_iocb (switch, iocbp, ec1); /* Pick up ptr to it if it exists */
		if ec1 ^= 0 then return;		/* Well, we tried */
		call CLOSE_AND_DETACH (iocbp, ec1);	/* Chec1k the gas while you're at it */
		if ec1 = 0 then go to attach;		/* Try again */
	     end;
	     return;
	end;

open:
	call iox_$open (iocbp, omode, "0"b, ec);

	return;

     end ATTACH_AND_OPEN;

/* Internal procedure to close and detach */

CLOSE_AND_DETACH: proc (iocbp, ec);

dcl  iocbp pointer parameter;
dcl  ec fixed bin (35) parameter;

	call iox_$close (iocbp, ec);
	call iox_$detach_iocb (iocbp, ec);
	iocbp = null ();
	return;
     end CLOSE_AND_DETACH;

/* Internal procedure to close and detach the ring 0 log and clean up */

CLOSE_R0_LOG: proc (ec);

dcl  ec fixed bin (35) parameter;

	call CLOSE_AND_DETACH (iop (1), ec);

	call delete_$path (get_pdir_ (), r0_vfile, "000100"b, "", ec);

	return;
     end CLOSE_R0_LOG;

/* Internal procedure to decode a record key */
/* Record keys are simply a bit string of concatenated message time, sequence number, and syserr code */

DECODE_KEY: proc (key, time, seq);

dcl  key char (256) varying parameter;
dcl  time fixed bin (71) parameter;
dcl  seq fixed bin (35) parameter;

dcl  keybits bit (9 * 16) aligned;			/* Overlay to pick out bit fields */
dcl  keychars char (16) based (addr (keybits));

	keychars = key;				/* Copy out of varying string because we aren't
						   supposed to know how varying strings are stored */

	time = fixed (substr (keybits, 1, 72), 71);
	seq = fixed (substr (keybits, 73, 36), 35);

	return;
     end DECODE_KEY;

/* special debugging entry that stores the vfile_ attach description in static */

debug: entry (arg_dir, arg_ename);

dcl  (arg_dir, arg_ename) char (*);

	call absolute_pathname_ (pathname_ (arg_dir, arg_ename), r4_path, ec);
	if ec ^= 0 then
	     call sub_err_ (ec, "old_syserr_log_util_$debug", ACTION_CANT_RESTART, null (), (0), "Bad pathname from ^a, ^a", arg_dir, arg_ename);
	R4_PATH = r4_path;
	return;
%page;
%include sub_err_flags;
%page;
%include syserr_log;
%page;
%include syserr_message;


     end old_syserr_log_util_;




		    print_sys_log.pl1               11/03/86  1035.8r   11/03/86  0953.3      334485



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


/* format: style2,indcomtxt */

print_sys_log:
psl:
     procedure () options (variable);

/* *	PRINT_SYS_LOG
   *
   *	Log-printing procedure for new-format (MR11) logs. See the info file
   *	for details of options too numerous to mention here.
   *
   *	Modification history:
   *	1984-06-05, W. Olin Sibert: Initial coding, inspired by print_syserr_log
   *	1984-08-23, WOS: Added -procedure, -line_length, -output_switch control arguments
   *	1984-10-09, E. Swenson: Fixed bug preventing "-last N" from working.
   *      1984-10-31, WOS: Added -XXX_format, calls to format_log_message_$adjust
   *      1984-12-05, WOS: Fixed for control argument changes, and to handle expansions
   *      1984-12-06, WOS: Added LOG_SELECTOR control arguments
   *	1984-12-06, WOS: Added -dm_sys_log
   *      1984-12-11, BIM: Converted to ssu_ standalone invocation.
   *	1984-12-20, WOS: Added -continuation_indent
   *	1984-12-26, BIM: Changed implementation of -ci to use -1 to mean "default" and to add "standard" keyword.
   *      1985-01-15, BIM: -pid, -data_class, -match/exclude_data_class.
   *	1985-02-07, Steve Herbst: Changed -dms to call dm_misc_util_$get_log_path.
   *	1985-03-13, Steve Herbst: Fixed to recheck time range at end of find_first_message. Fixes bug where
   *		if no messages within time range, procedure was getting the previous and next messages.
   *	1985-03-14, Steve Herbst: Fixed to reject "/foo", "foo/", and "/"
   *		as invalid regular expressions.
   *	1985-03-21, Steve Herbst: Fixed not to recheck time range if the
   *		argument to -from/-to is a sequence number not a time.
   *	1985-04-16, Steve Herbst: Re-implemented -no_data_class, removed
   *		recently by accident.
   *	1985-05-01, Steve Herbst: Fixed to ensure from_time<=to_time.
*/


/****^  HISTORY COMMENTS:
  1) change(86-04-29,Kissel), approve(86-07-31,MCR7456), audit(86-08-01,Wong),
     install(86-11-03,MR12.0-1149):
     Changed to support DSA system and system aep logs, using the -dsasl and
     -dsasal control arguments.  Also increased the size of an automatic
     string which holds interpreted output so longer interpretations could be
     supported.
                                                   END HISTORY COMMENTS */


	declare DM_READER_PROCEDURE	 char (32) init ("dm_log_read_") int static options (constant);
	declare DSA_READER_PROCEDURE	 char (32) init ("dsa_log_admin_gate_") int static options (constant);

	declare dm_system_log_path	 char (168);
	declare dsa_system_log_path	 char (168);
	declare code		 fixed bin (35);

	declare log_read_data_ptr	 pointer;

	declare 1 opt		 automatic,	/* Miscellaneous options for the command itself; */
		2 log_pathname	 char (168),	/* note that formatting options are kept separately */
		2 log_dname	 char (168),	/* in the log_message_format structure */
		2 log_ename	 char (32),
		2 pointers,
		  3 expand_select_ptr
				 pointer,
		  3 lmd_ptr	 pointer,
		2 limit		 aligned like log_limit_info,
		2 reader_procedure	 char (32) varying,
		2 iocb		 pointer,
		2 flags		 aligned,
		  3 debug_sw	 bit (1),
		  3 dm_system_log_sw bit (1),
		  3 reverse_sw	 bit (1),
		  3 from_sw	 bit (1),
		  3 to_sw		 bit (1),
		  3 for_sw	 bit (1),
		  3 last_sw	 bit (1),
		  3 expand_sw	 bit (1),
		  3 octal_sw	 bit (1),
		  3 interpret_sw	 bit (1),
		  3 log_path_sw	 bit (1),
		  3 no_header_sw	 bit (1),
		  3 limit_sw	 bit (1),
		  3 process_id_sw	 bit (1),
		  3 data_class_sw	 bit (1),
		  3 dsa_system_log_sw
				 bit (1);

	declare expand_this_message	 bit (1) aligned;
	declare expand_mode_ptr	 pointer;
	declare expansion		 char (30000) varying;

	declare (fb71_from_time, fb71_to_time)
				 fixed bin (71);

	declare 1 log_open_info	 aligned like log_read_open_info;

	declare sci_ptr		 pointer;

	declare error_table_$bad_arg	 fixed bin (35) external static;
	declare error_table_$bad_conversion
				 fixed bin (35) external static;
	declare error_table_$badopt	 fixed bin (35) external static;
	declare error_table_$invalid_conversion
				 fixed bin (35) external static;
	declare error_table_$moderr	 fixed bin (35) external static;
	declare error_table_$noentry	 fixed bin (35) external static;
	declare error_table_$no_log_message
				 fixed bin (35) external static;
	declare error_table_$noarg	 fixed bin (35) external static;
	declare error_table_$too_many_args
				 fixed bin (35) external static;


	declare iox_$user_output	 pointer external static;

	declare check_gate_access_	 entry (char (*), ptr, fixed bin (35));
	declare com_err_		 entry options (variable);
	declare convert_date_to_binary_
				 entry (char (*), fixed bin (71), fixed bin (35));
	declare cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	declare cu_$arg_list_ptr	 entry returns (pointer);
	declare dm_misc_util_$get_log_path
				 entry (char (*));
	declare dsa_nit_$get_field	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare get_line_length_$switch
				 entry (pointer, fixed bin (35)) returns (fixed bin);
	declare ioa_$ioa_switch	 entry options (variable);
	declare iox_$look_iocb	 entry (char (*), pointer, fixed bin (35));
	declare iox_$put_chars	 entry (pointer, pointer, fixed bin (21), fixed bin (35));
	declare pathname_		 entry (char (*), char (*)) returns (char (168));

	declare log_format_time_	 entry (fixed bin (71)) returns (char (32) varying);
	declare expand_log_message_	 entry (pointer, pointer, pointer, char (*) varying, fixed bin (35));
	declare expand_log_message_$append_octal
				 entry (pointer, pointer, fixed binary, character (*) var);
	declare expand_log_message_$append_process_id
				 entry (pointer, pointer, character (*) var);
	declare expand_log_message_$append_data_class
				 entry (pointer, pointer, character (*) var);
	declare format_log_message_$init
				 entry (pointer);
	declare format_log_message_$adjust
				 entry (pointer, fixed bin (35));
	declare format_log_message_$free
				 entry (pointer);
	declare format_log_message_$format
				 entry (pointer, pointer, pointer, char (*) varying, char (*) varying,
				 fixed bin (35));

	declare log_limit_scan_	 entry (pointer, pointer, bit (1) aligned, pointer);
	declare log_expand_select_$add entry (pointer, char (*), fixed bin (35));
	declare log_expand_select_$free
				 entry (pointer);
	declare log_expand_select_$test
				 entry (pointer, pointer, bit (1) aligned, pointer);
	declare log_match_$add_match	 entry (pointer, char (*));
	declare log_match_$add_exclude entry (pointer, char (*));
	declare log_match_$add_match_data
				 entry (pointer, char (*));
	declare log_match_$add_exclude_data
				 entry (pointer, char (*));
	declare log_match_$add_match_data_class
				 entry (pointer, character (*));
	declare log_match_$add_exclude_data_class
				 entry (pointer, character (*));
	declare log_match_$clear_text_strings
				 entry (pointer);
	declare log_match_$clear_data_strings
				 entry (pointer);
	declare log_match_$clear_data_class_strings
				 entry (pointer);
	declare log_match_$add_severity
				 entry (pointer, fixed bin, fixed bin);
	declare log_match_$clear_severity
				 entry (pointer);
	declare log_match_$free	 entry (pointer);
	declare log_match_$test	 entry (pointer, pointer, char (*) varying) returns (bit (1) aligned);
	declare log_read_$open	 entry (char (*), char (*), pointer, fixed bin (35));
	declare log_read_$open_long	 entry (character (*), character (*), pointer, pointer, fixed binary (35));
	declare log_read_$close	 entry (pointer, fixed bin (35));
	declare log_read_$next_message entry (pointer, pointer, fixed bin (35));
	declare log_read_$prev_message entry (pointer, pointer, fixed bin (35));
	declare ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	declare ssu_$arg_count	 entry (ptr, fixed bin);
	declare ssu_$abort_line	 entry options (variable);
	declare ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	declare ssu_$destroy_invocation
				 entry (ptr);
	declare ssu_$get_area	 entry (ptr, ptr, char (*), ptr);
	declare ssu_$set_debug_mode	 entry (ptr, bit (1) aligned);

	declare cleanup		 condition;

	declare WHOAMI		 char (32) internal static options (constant) init ("print_sys_log");
	declare DEFAULT_LINE_LENGTH	 fixed bin internal static options (constant) init (132);

	declare (abs, addr, addwordno, after, before, char, dimension, index, length, null, substr, unspec)
				 builtin;

/**/

	log_read_data_ptr = null ();
	log_message_format_ptr = null ();
	sci_ptr = null ();

	on cleanup
	     begin;				/* Temporary cleanup handler until opt is initialized */
		if sci_ptr ^= null ()
		then call ssu_$destroy_invocation (sci_ptr);
	     end;

	call ssu_$standalone_invocation (sci_ptr, WHOAMI, "1.0", cu_$arg_list_ptr (), ssu_abort, code);
	if code ^= 0
	then do;
		call com_err_ (code, WHOAMI, "Failed to create ssu_ invocation.");
		return;
	     end;

	call initialize_options ();



	on condition (cleanup) call clean_up ();


	call process_arguments ();


	if opt.reader_procedure = ""
	then call log_read_$open (opt.log_dname, opt.log_ename, log_read_data_ptr, code);
	else do;
		log_open_info.version = LOG_READ_OPEN_INFO_VERSION_1;
		log_open_info.reader_procedure = opt.reader_procedure;
		call ssu_$get_area (sci_ptr, null (), "log_read_ copies", log_open_info.allocation_area_ptr);
		log_open_info.allocate_copies = "0"b;	/* That is the inner-ring's job */
		call log_read_$open_long (opt.log_dname, opt.log_ename, addr (log_open_info), log_read_data_ptr, code)
		     ;
	     end;

	if (code ^= 0)
	then call ssu_$abort_line (sci_ptr, code, "Cannot open ^a", opt.log_pathname);

	call log_limit_scan_ (sci_ptr, addr (opt.limit), opt.reverse_sw, log_read_data_ptr);

	call find_first_message ();

	call print_limits ();

	call process_messages ();

MAIN_RETURN:					/* This is the ONLY return statement for this procedure */
	call clean_up ();				/* do the cleanup in the main activation, not the error procedure. */
	return;


ssu_abort:
     procedure ();					/* procedure called by ssu_ when there is a call to abort_line, which is how all errors are reported */
	goto MAIN_RETURN;

     end ssu_abort;



clean_up:
     procedure ();

	if (opt.lmd_ptr ^= null ())
	then call log_match_$free (opt.lmd_ptr);

	if (opt.expand_select_ptr ^= null ())
	then call log_expand_select_$free (opt.expand_select_ptr);

	if (log_read_data_ptr ^= null ())
	then call log_read_$close (log_read_data_ptr, (0));

	if (log_message_format_ptr ^= null ())
	then call format_log_message_$free (log_message_format_ptr);

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

/**/

find_first_message:
     procedure ();

	declare exchange_ptr	 pointer;
	declare total_count		 fixed bin;
	declare match_count		 fixed bin;
	declare matching_message_ptr	 pointer;

/* This procedure locates the message we're going to start with, in case we're
   doing something like "-last 10", where log_limit_scan_ can't determine the
   real starting point because it depends on the content of the messages. */

	total_count = 0;

/* First, we swap the limits if we're going to be printing backwards */

	if opt.reverse_sw
	then do;
		exchange_ptr = opt.first_msg;
		opt.first_msg = opt.last_msg;
		opt.last_msg = exchange_ptr;
	     end;

	if (opt.first_msg ^= null ())
	then /* We know where we're starting */
	     go to FOUND;

/* Otherwise, we look backwards to find where to start.  We are guaranteed,
   by log_limit_scan_, that at least one limit is non-null, and also that if
   one is null, there is a limit count. If, however, we run out of messages
   before we hit the limit, that's still OK, and we print all that we have. */

	match_count = 0;
	log_message_ptr = opt.last_msg;
	matching_message_ptr = null ();		/* Most recent matching message */

	do total_count = 1 by 1 while (match_count < opt.msg_count);
	     if message_matches ()
	     then do;
		     match_count = match_count + 1;
		     matching_message_ptr = log_message_ptr;
		end;

	     call prev_message ();
	     if (log_message_ptr = null ())
	     then /* If we've run out, terminate the loop */
		match_count = opt.msg_count;
	end;

	if (matching_message_ptr = null ())
	then
NO_MESSAGES:
	     call ssu_$abort_line (sci_ptr, 0, "No messages matched criteria. ^d message^[s^] read.", total_count,
		(total_count ^= 1));

	opt.first_msg = matching_message_ptr;
FOUND:
	return;

     end find_first_message;

/**/

print_limits:
     procedure ();

	if opt.no_header_sw
	then return;

	if (opt.first_msg = null ())
	then call ioa_$ioa_switch (opt.iocb, "Log ^a to ^a", opt.log_pathname,
		log_format_time_ ((opt.last_msg -> log_message.time)));

	else if (opt.last_msg = null ())
	then call ioa_$ioa_switch (opt.iocb, "Log ^a from ^a", opt.log_pathname,
		log_format_time_ ((opt.first_msg -> log_message.time)));

	else call ioa_$ioa_switch (opt.iocb, "Log ^a from ^a to ^a", opt.log_pathname,
		log_format_time_ ((opt.first_msg -> log_message.time)),
		log_format_time_ ((opt.last_msg -> log_message.time)));

	return;
     end print_limits;

/**/

process_messages:
     procedure ();

	declare prev_message_ptr	 pointer;
	declare message_limit	 fixed bin (35);
	declare message_count	 fixed bin (35);


	prev_message_ptr = null ();
	log_message_ptr = opt.first_msg;

	if (opt.msg_count > 0)
	then message_limit = opt.msg_count;
	else message_limit = 100000000;		/* Meaning, everything */
	message_count = 0;

	do while (log_message_ptr ^= null ());		/* Catch running out of messages benignly */
	     if message_matches ()
	     then /* Print it if it matches */
		call process_a_message ();

	     if (log_message_ptr = opt.last_msg)
	     then /* All done */
		return;

	     if (message_count >= message_limit)
	     then /* Ran out of requested messages */
		return;

	     call next_message ();
	end;

	return;



process_a_message:
     procedure ();

	declare output_buffer	 char (30000) varying;

/* This is where we put the selection tests */

	message_count = message_count + 1;

	if ^opt.interpret_sw
	then /* If not interpreting, then definitely not */
	     expand_this_message = "0"b;
	else if (dimension (log_message.data, 1) = 0)
	then /* And, if no data, also definitely not */
	     expand_this_message = "0"b;
	else if (opt.expand_select_ptr = null ())
	then do;					/* But if we are interpreting, and no classes were */
		expand_this_message = "1"b;		/* asked for, we do expand this one's data */
		expand_mode_ptr = null ();		/* But, obviously, there were no expand modes asked for */
	     end;
	else call log_expand_select_$test
		/* Otherwise, we ask the selector */ (opt.expand_select_ptr, log_message_ptr, expand_this_message,
		expand_mode_ptr);

	if expand_this_message
	then call expand_log_message_ (log_message_format_ptr, log_message_ptr, expand_mode_ptr, expansion, (0));
	else expansion = "";			/* This one has nothing for the formatter */
	if opt.octal_sw
	then call expand_log_message_$append_octal (log_message_format_ptr, addr (log_message.data),
		(log_message.data_lth), expansion);
	if opt.data_class_sw & log_message.data_class ^= ""
	then call expand_log_message_$append_data_class (log_message_format_ptr, log_message_ptr, expansion);
	if opt.process_id_sw
	then call expand_log_message_$append_process_id (log_message_format_ptr, log_message_ptr, expansion);

	call format_log_message_$format (log_message_format_ptr, log_message_ptr, prev_message_ptr, expansion,
	     output_buffer, (0));

	call iox_$put_chars (opt.iocb, addwordno (addr (output_buffer), 1), length (output_buffer), (0));
						/* Buffer contains own newline */
	prev_message_ptr = log_message_ptr;

	return;
     end process_a_message;

     end process_messages;

/**/

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

/* This procedure determines whether the current message matches selection
   criteria. It first checks the text of the message, then, if that matches,
   expands the binary data (if any) and tries again. */

	if (^log_match_$test (opt.lmd_ptr, log_message_ptr, ""))
	then return ("0"b);

	if ^opt.interpret_sw
	then return ("1"b);				/* No need to expand */

	if opt.expand_select_ptr = null ()
	then do;
		expand_this_message = "1"b;
		expand_mode_ptr = null ();
	     end;
	else call log_expand_select_$test (opt.expand_select_ptr, log_message_ptr, expand_this_message, expand_mode_ptr)
		;

	if ^expand_this_message
	then return ("1"b);				/* No expand, no exclude on expansion */
	call expand_log_message_ (log_message_format_ptr, log_message_ptr, expand_mode_ptr, expansion, (0));

	return (log_match_$test (opt.lmd_ptr, log_message_ptr, expansion));
     end message_matches;

next_message:
     procedure ();

/* This procedure advances to the next message, returning with log_message_ptr
   set to null when it encounters no further messages. */

	if opt.reverse_sw
	then call log_read_$prev_message (log_read_data_ptr, log_message_ptr, code);
	else call log_read_$next_message (log_read_data_ptr, log_message_ptr, code);

	if (code = error_table_$no_log_message)
	then log_message_ptr = null ();		/* Force quiet loop termination */

	else if (code ^= 0)
	then call ssu_$abort_line (sci_ptr, code, "Reading next message.");

	return;
     end next_message;				/*						*/
prev_message:
     procedure ();

/* This procedure advances to the previous message, returning with log_message_ptr
   set to null when it encounters no further messages. */

	if opt.reverse_sw
	then call log_read_$next_message (log_read_data_ptr, log_message_ptr, code);
	else call log_read_$prev_message (log_read_data_ptr, log_message_ptr, code);

	if (code = error_table_$no_log_message)
	then log_message_ptr = null ();		/* Force quiet loop termination */

	else if (code ^= 0)
	then call ssu_$abort_line (sci_ptr, code, "Reading previous message.");

	return;
     end prev_message;

/**/

initialize_options:
     procedure ();

/* This must be run before the cleanup handler gets set up */

	unspec (opt) = ""b;				/* Turn all options off */
	opt.pointers = null ();			/* Aggregate assignment */
	opt.limit.version = LOG_LIMIT_INFO_VERSION_1;
	opt.limit.to_opt = "";			/* Set up to call the limit scanner */
	opt.limit.from_opt = "";
	opt.limit.for_opt = "";
	opt.limit.last_opt = "";
	opt.log_pathname = "";
	opt.iocb = iox_$user_output;

	call format_log_message_$init (log_message_format_ptr);
	log_message_format.caller = WHOAMI;
	log_message_format.equal_sw = "1"b;		/* Default */

	log_message_format.line_lth = get_line_length_$switch (opt.iocb, code);
	if (code ^= 0)
	then log_message_format.line_lth = DEFAULT_LINE_LENGTH;
						/* Pretend to be a printer, by default */

	call adjust_log_message_format ("Initializing log_message_format structure", "");

	opt.reader_procedure = "";			/* Default */
	return;
     end initialize_options;

/**/

process_arguments:
     procedure ();

	declare arg		 char (arg_lth) based (arg_ptr);
	declare arg_lth		 fixed bin (21);
	declare arg_ptr		 pointer;
	declare arg_count		 fixed bin;
	declare arg_idx		 fixed bin;

	declare looking_for		 fixed bin;
	declare number_arg		 char (20) varying;
	declare pathname_arg	 char (168) varying;
	declare iocb_arg		 char (32) varying;

	declare LOG_PATHNAME	 init (1) fixed bin internal static options (constant);
	declare MATCH_STRING	 init (2) fixed bin internal static options (constant);
	declare EXCLUDE_STRING	 init (3) fixed bin internal static options (constant);
	declare MATCH_DATA_STRING	 init (4) fixed bin internal static options (constant);
	declare EXCLUDE_DATA_STRING	 init (5) fixed bin internal static options (constant);
	declare SEVERITY		 init (6) fixed bin internal static options (constant);
	declare EXPAND_TYPE		 init (8) fixed bin internal static options (constant);
	declare MATCH_DATA_CLASS_STRING
				 init (9) fixed bin internal static options (constant);
	declare EXCLUDE_DATA_CLASS_STRING
				 init (10) fixed bin internal static options (constant);
						/*						*/

	call ssu_$arg_count (sci_ptr, arg_count);

	looking_for = 0 - LOG_PATHNAME;		/* Start out "casually" looking for a pathname */

	do arg_idx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_lth);

	     if (looking_for > 0)
	     then do;				/* First one after a control argument */
		     call process_looking_for ();	/* -match -fred matches "-fred", but */
		     looking_for = 0 - looking_for;	/* -match str -fred is an error */
		end;				/* "Casually" looking for signalled by negative value */

	     else if (arg = "-syserr")
	     then call set_pathname (">sl1>syserr_log");
	     else if (arg = "-answering_service") | (arg = "-as")
	     then call set_pathname (">sc1>as_logs>log");
	     else if (arg = "-admin")
	     then call set_pathname (">sc1>as_logs>admin_log");
	     else if (arg = "-pathname") | (arg = "-pn")
	     then do;
		     call get_next_arg (pathname_arg);
		     call set_pathname (pathname_arg);
		end;
	     else if (arg = "-mc_log") | (arg = "-mcl")
	     then do;
		     call get_next_arg (pathname_arg);
		     call set_pathname (">sc1>as_logs>" || pathname_arg);
		end;
	     else if (arg = "-dm_system") | (arg = "-dms")
	     then do;
		     opt.dm_system_log_sw = "1"b;
		     call dm_misc_util_$get_log_path (dm_system_log_path);
		     call set_pathname ((dm_system_log_path));
		     opt.reader_procedure = DM_READER_PROCEDURE;
		end;

	     else if (arg = "-dsa_sys_log") | (arg = "-dsasl")
	     then do;
		     opt.dsa_system_log_sw = "1"b;

		     /*** Check to see if we will succeed. */

		     call check_gate_access_ (DSA_READER_PROCEDURE, null (), code);

		     if code = error_table_$noentry
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "DSA is not installed on this system.")
			     ;
		     else if code = error_table_$moderr
		     then call ssu_$abort_line (sci_ptr, code, "You need e access to ^a to read the DSA log.",
			     DSA_READER_PROCEDURE);
		     else if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Trying to check the access to: ^a.",
			     DSA_READER_PROCEDURE);

		     /*** The code was 0, proceed. */

		     else call dsa_nit_$get_field ("mna_general_info", "", "dsa_system_log", dsa_system_log_path,
			     code);

		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Cannot find the name of the dsa system log.");

		     call set_pathname ((dsa_system_log_path));
		     opt.reader_procedure = DSA_READER_PROCEDURE;
		end;

	     else if (arg = "-dsa_sys_aep_log") | (arg = "-dsasal")
	     then do;
		     opt.dsa_system_log_sw = "1"b;

		     /*** Check to see if we will succeed. */

		     call check_gate_access_ (DSA_READER_PROCEDURE, null (), code);

		     if code = error_table_$noentry
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "DSA is not installed on this system.")
			     ;
		     else if code = error_table_$moderr
		     then call ssu_$abort_line (sci_ptr, code, "You need e access to ^a to read the DSA log.",
			     DSA_READER_PROCEDURE);
		     else if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Trying to check the access to: ^a.",
			     DSA_READER_PROCEDURE);

		     /*** The code was 0, proceed. */

		     else call dsa_nit_$get_field ("mna_general_info", "", "dsa_system_aep_log", dsa_system_log_path,
			     code);

		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Cannot find the name of the dsa system aep log.");

		     call set_pathname ((dsa_system_log_path));
		     opt.reader_procedure = DSA_READER_PROCEDURE;
		end;

	     else if (arg = "-forward") | (arg = "-fwd")
	     then opt.reverse_sw = "0"b;
	     else if (arg = "-reverse") | (arg = "-rv")
	     then opt.reverse_sw = "1"b;
	     else if (arg = "-header") | (arg = "-he")
	     then opt.no_header_sw = "0"b;
	     else if (arg = "-no_header") | (arg = "-nhe")
	     then opt.no_header_sw = "1"b;
	     else if (arg = "-duplicates") | (arg = "-dup")
	     then do;
		     log_message_format.equal_sw = "0"b;
		     call adjust_log_message_format ("Processing -duplicates argument.", "");
		end;

	     else if (arg = "-debug") | (arg = "-db")
	     then do;
		     log_message_format.equal_sw = "0"b;
		     call adjust_log_message_format ("Processing -debug argument.", "");
		     opt.debug_sw = "1"b;
		     call ssu_$set_debug_mode (sci_ptr, "1"b);
		end;

	     else if (arg = "-no_duplicates") | (arg = "-ndup")
	     then do;
		     log_message_format.equal_sw = "1"b;
		     call adjust_log_message_format ("Processing -no_duplicates argument.", "");
		end;

	     else if (arg = "-absolute_pathname") | (arg = "-absp")
	     then opt.log_path_sw = "1"b;
	     else if (arg = "-no_absolute_pathname") | (arg = "-nabsp")
	     then opt.log_path_sw = "1"b;
	     else if (arg = "-limits") | (arg = "-lim")
	     then opt.limit_sw = "1"b;

	     else if (arg = "-match") | (arg = "-mh")
	     then looking_for = MATCH_STRING;
	     else if (arg = "-exclude") | (arg = "-ex")
	     then looking_for = EXCLUDE_STRING;
	     else if (arg = "-match_data") | (arg = "-md")
	     then looking_for = MATCH_DATA_STRING;
	     else if (arg = "-exclude_data") | (arg = "-exd")
	     then looking_for = EXCLUDE_DATA_STRING;
	     else if (arg = "-match_data_class") | (arg = "-mdc")
	     then looking_for = MATCH_DATA_CLASS_STRING;
	     else if (arg = "-exclude_data_class") | (arg = "-exdc")
	     then looking_for = EXCLUDE_DATA_CLASS_STRING;
	     else if (arg = "-all_data_classes") | (arg = "-adc")
	     then call log_match_$clear_data_class_strings (opt.lmd_ptr);
	     else if (arg = "-all_text") | (arg = "-atxt")
	     then call log_match_$clear_text_strings (opt.lmd_ptr);
	     else if (arg = "-all_data") | (arg = "-ad")
	     then call log_match_$clear_data_strings (opt.lmd_ptr);

	     else if (arg = "-severity") | (arg = "-sv") | (arg = "-action")
	     then looking_for = SEVERITY;

	     else if (arg = "-all_severities") | (arg = "-asv")
	     then call log_match_$clear_severity (opt.lmd_ptr);

	     else if (arg = "-process_id") | (arg = "-pid")
	     then opt.process_id_sw = "1"b;

	     else if (arg = "-no_process_id") | (arg = "-npid")
	     then opt.process_id_sw = "0"b;

	     else if (arg = "-data_class") | (arg = "-dc")
	     then opt.data_class_sw = "1"b;

	     else if (arg = "-no_data_class") | (arg = "-ndc")
	     then opt.data_class_sw = "0"b;

/**** -match_data_class, -exclude_data_class, -all_data_classes */

	     else if (arg = "-expand") | (arg = "-exp")
	     then do;
		     looking_for = (0 - EXPAND_TYPE);	/* Don't necessarily eat the next argument */
		     opt.expand_sw = "1"b;
		end;

	     else if (arg = "-no_expand") | (arg = "-nexp")
	     then do;
		     opt.expand_sw = "0"b;
		     opt.octal_sw = "0"b;
		     opt.interpret_sw = "0"b;
		end;

	     else if (arg = "-octal") | (arg = "-oc")
	     then do;
		     opt.expand_sw = "1"b;
		     opt.octal_sw = "1"b;
		end;

	     else if (arg = "-interpret") | (arg = "-int") | (arg = "-it")
	     then do;
		     opt.expand_sw = "1"b;
		     opt.interpret_sw = "1"b;
		end;


	     else if (arg = "-from") | (arg = "-fm")
	     then call get_next_arg (opt.limit.from_opt);
	     else if (arg = "-last") | (arg = "-lt")
	     then call get_next_arg (opt.limit.last_opt);
	     else if (arg = "-to")
	     then call get_next_arg (opt.limit.to_opt);
	     else if (arg = "-for") | (arg = "-next")
	     then call get_next_arg (opt.limit.for_opt);

	     else if (arg = "-procedure") | (arg = "-proc")
	     then call get_next_arg (opt.reader_procedure);

	     else if (arg = "-line_length") | (arg = "-ll")
	     then do;
		     call get_next_arg (number_arg);
		     log_message_format.line_lth = cv_dec_check_ ((number_arg), code);
		     if (code ^= 0) | (log_message_format.line_lth < 25) | (log_message_format.line_lth > 500)
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
			     "Line length must be between 25 and 500, not ^a", number_arg);

		     call adjust_log_message_format ("Processing -line_length.", arg);
		end;				/* Of -line_length processing */

	     else if (arg = "-output_switch") | (arg = "-osw")
	     then do;
		     call get_next_arg (iocb_arg);
		     call iox_$look_iocb ((iocb_arg), opt.iocb, code);
		     if (code ^= 0)
		     then call ssu_$abort_line (sci_ptr, code, "I/O switch ^a", iocb_arg);

		     log_message_format.line_lth = get_line_length_$switch (opt.iocb, code);
		     if (code ^= 0)
		     then /* Must reset the line length, also reapply the default */
			log_message_format.line_lth = DEFAULT_LINE_LENGTH;

		     call adjust_log_message_format ("Setting line length from -output_switch", arg);
		end;				/* Of -line_length processing */

	     else if (arg = "-indent") | (arg = "-ind") | (arg = "-in")
	     then do;
		     call get_next_arg (number_arg);
		     log_message_format.indentation = cv_dec_check_ ((number_arg), code);
		     if (code ^= 0) | (log_message_format.indentation < 0) | (log_message_format.indentation > 50)
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
			     "Indentation must be between 0 and 50, not ^a", number_arg);

		     call adjust_log_message_format ("Processing -indent", arg);
		end;				/* Of -indent processing */

	     else if (arg = "-continuation_indent") | (arg = "-ci")
	     then do;
		     call get_next_arg (number_arg);
		     if number_arg = "standard" | number_arg = "std"
		     then log_message_format.continuation_indent = -1;
		     else do;
			     log_message_format.continuation_indent = cv_dec_check_ ((number_arg), code);
			     if (code ^= 0) | (log_message_format.continuation_indent < 0)
				| (log_message_format.continuation_indent > 50)
			     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				     "Continuation indent must be between 0 and 50 or ""standard"", not ^a",
				     number_arg);

			end;
		     call adjust_log_message_format ("Processing -continuation_indent", arg);
		end;				/* Of -continuation_indent processing */

	     else if (arg = "-prefix") | (arg = "-pfx")
	     then do;
		     call get_next_arg (log_message_format.prefix);
		     call adjust_log_message_format ("Processing -prefix", arg);
		end;				/* Of -prefix processing */


	     else if (arg = "-time_format") | (arg = "-tfmt")
	     then do;
		     call get_next_arg (log_message_format.time_format);
		     call adjust_log_message_format ("Processing -time_format", arg);
		end;

	     else if (arg = "-date_format") | (arg = "-dfmt")
	     then do;
		     call get_next_arg (log_message_format.date_format);
		     call adjust_log_message_format ("Processing -date_format", arg);
		end;

	     else if (arg = "-number_format") | (arg = "-nfmt")
	     then do;
		     call get_next_arg (log_message_format.number_format);
		     call adjust_log_message_format ("Processing -number_format", arg);
		end;

	     else if (index (arg, "-") = 1)
	     then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);

	     else call process_looking_for ();
	end;					/* of loop through arguments */

	call check_options ();

	return;					/* End of argument processing */

/**/

process_looking_for:
     procedure ();

	declare really_looking_for	 fixed bin;
	declare severity1		 fixed bin;
	declare severity2		 fixed bin;


	really_looking_for = abs (looking_for);

/* Weed out invalid regular expressions in match/exclude args */

	if really_looking_for = MATCH_STRING | really_looking_for = EXCLUDE_STRING
	     | really_looking_for = MATCH_DATA_STRING | really_looking_for = EXCLUDE_DATA_STRING
	     | really_looking_for = MATCH_DATA_CLASS_STRING | really_looking_for = EXCLUDE_DATA_CLASS_STRING
	then if substr (arg, 1, 1) = "/" & substr (arg, arg_lth, 1) ^= "/"
	     then
INVALID_REGULAR_EXPRESSION:
		call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Invalid regular expression ""^a""", arg);
	     else if substr (arg, arg_lth, 1) = "/" & substr (arg, 1, 1) ^= "/"
	     then go to INVALID_REGULAR_EXPRESSION;
	     else if arg = "/"
	     then go to INVALID_REGULAR_EXPRESSION;


	if (really_looking_for = LOG_PATHNAME)
	then call set_pathname ((arg));

	else if (really_looking_for = MATCH_STRING)
	then call log_match_$add_match (opt.lmd_ptr, arg);

	else if (really_looking_for = EXCLUDE_STRING)
	then call log_match_$add_exclude (opt.lmd_ptr, arg);

	else if (really_looking_for = MATCH_DATA_STRING)
	then call log_match_$add_match_data (opt.lmd_ptr, arg);

	else if (really_looking_for = EXCLUDE_DATA_STRING)
	then call log_match_$add_exclude_data (opt.lmd_ptr, arg);

	else if (really_looking_for = MATCH_DATA_CLASS_STRING)
	then call log_match_$add_match_data_class (opt.lmd_ptr, arg);

	else if (really_looking_for = EXCLUDE_DATA_CLASS_STRING)
	then call log_match_$add_exclude_data_class (opt.lmd_ptr, arg);

	else if (really_looking_for = SEVERITY)
	then do;
		severity1 = cv_dec_check_ (before (arg, ":"), code);
		if (code ^= 0)
		then
INVALID_SEVERITY_RANGE:
		     call ssu_$abort_line (sci_ptr, error_table_$invalid_conversion,
			"Invalid severity value ""^a"": must be <N> or <N>:<M>", arg);

		if (index (arg, ":") = 0)
		then /* Not a range, just a single number */
		     severity2 = severity1;
		else severity2 = cv_dec_check_ (after (arg, ":"), code);
		if (code ^= 0)
		then goto INVALID_SEVERITY_RANGE;

		call log_match_$add_severity (opt.lmd_ptr, severity1, severity2);
	     end;

	else if (really_looking_for = EXPAND_TYPE)
	then do;
		call log_expand_select_$add (opt.expand_select_ptr, arg, code);
		if (code ^= 0)
		then call ssu_$abort_line (sci_ptr, code, "Invalid expansion type/modes: ""^a"".", arg);
	     end;

	return;
     end process_looking_for;

/**/

get_next_arg:
     procedure (P_option);

	declare P_option		 char (*) varying parameter;


	if (arg_idx >= arg_count)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Value missing after ^a", arg);

	arg_idx = arg_idx + 1;
	call ssu_$arg_ptr (sci_ptr, arg_idx, arg_ptr, arg_lth);

	P_option = arg;

	return;
     end get_next_arg;



set_pathname:
     procedure (P_pathname);

	declare P_pathname		 char (*) varying parameter;

/* This is a separate procedure both for convenience, and also to ease the
   implementation of reading multiple logs-- just take out the restriction,
   and add the proper support in open. */


	if (opt.log_pathname ^= "")
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one log pathname: ^a invalid", P_pathname)
		;

	call expand_pathname_ ((P_pathname), opt.log_dname, opt.log_ename, code);
	if (code ^= 0)
	then call ssu_$abort_line (sci_ptr, code, "Invalid log pathname: ^a", P_pathname);

	opt.log_pathname = pathname_ (opt.log_dname, opt.log_ename);
						/* Value used in messages */

	return;
     end set_pathname;

/**/

check_options:
     procedure ();

	dcl     temp_number		 fixed bin;
	dcl     (from_time, to_time)	 fixed bin (71);
	dcl     exchange_opt	 char (50) varying;
	dcl     code		 fixed bin (35);

	if (opt.log_pathname = "")
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage:^-^a  LOG-SELECTOR  {-control_args}", WHOAMI);

	if (looking_for > 0)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "After ^a", arg);

	if opt.expand_sw & ^(opt.octal_sw | opt.interpret_sw)
	then opt.interpret_sw = "1"b;			/* If neither specified, default is -interpret */

/* Make sure the -from time is less than the -to time */

	if opt.limit.from_opt ^= "" & opt.limit.to_opt ^= ""
	then do;
		temp_number = cv_dec_check_ ((opt.limit.from_opt), code);
		if code ^= 0
		then do;
			temp_number = cv_dec_check_ ((opt.limit.to_opt), code);
			if code ^= 0
			then do;
				call convert_date_to_binary_ ((opt.limit.from_opt), from_time, 0);
				call convert_date_to_binary_ ((opt.limit.to_opt), to_time, 0);
				if from_time > to_time
				then do;
					exchange_opt = opt.limit.from_opt;
					opt.limit.from_opt = opt.limit.to_opt;
					opt.limit.to_opt = exchange_opt;
				     end;
			     end;
		     end;
	     end;

	return;

     end check_options;

     end process_arguments;

/**/

adjust_log_message_format:
     procedure (P_doing_what, P_doing_it_with);

	declare P_doing_what	 char (*) parameter;
	declare P_doing_it_with	 char (*) parameter;


	call format_log_message_$adjust (log_message_format_ptr, code);
	if (code = 0)
	then /* All OK */
	     return;

	call ssu_$abort_line (sci_ptr, code, "^a ^a",	/* Hope this identifies the source of error correctly */
	     P_doing_what, P_doing_it_with);		/* There are many possible errors from $adjust */

     end adjust_log_message_format;

%page;
%include log_message;
%page;
%include log_message_format;
%page;
%include log_limit_info;
%page;
%include log_read_open_info;
     end print_sys_log;




		    set_log_history_dir.pl1         04/09/85  1353.7r w 04/08/85  1133.0       40896



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: style2,indcomtxt */
set_log_history_dir:
     procedure () options (variable);

/**** Modification History:
      Created 1985-01-16, BIM */


	declare arg		 char (arg_lth) based (arg_ptr);
	declare arg_lth		 fixed bin (21);
	declare arg_ptr		 pointer;
	declare arg_count		 fixed bin;
	declare code		 fixed bin (35);
	declare log_dname		 char (168);
	declare log_ename		 char (32);
	declare log_history_dir	 char (168);
	declare sci_ptr		 pointer;
	declare type		 fixed bin (2);
	declare yes		 bit (1) aligned;

	declare absolute_pathname_	 entry (character (*), character (*), fixed binary (35));
	declare com_err_		 entry options (variable);
	declare command_query_$yes_no	 entry () options (variable);

	declare cu_$arg_list_ptr	 entry returns (pointer);
	declare expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	declare initiate_file_	 entry (character (*), character (*), bit (*), pointer, fixed binary (24),
				 fixed binary (35));
	declare pathname_		 entry (char (*), char (*)) returns (char (168));

	declare ssu_$arg_count	 entry (ptr, fixed bin);
	declare ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	declare ssu_$destroy_invocation
				 entry (ptr);
	declare ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	declare ssu_$abort_line	 entry () options (variable);
	declare terminate_file_	 entry (pointer, fixed binary (24), bit (*), fixed binary (35));

	declare error_table_$notadir	 fixed bin (35) ext static;
	declare error_table_$noentry	 fixed bin (35) ext static;

	declare cleanup		 condition;


	declare COMMAND_NAME	 char (32) internal static options (constant) init ("set_log_history_dir");


	sci_ptr, log_segment_ptr = null ();

	on condition (cleanup) call clean_up ();

	call ssu_$standalone_invocation (sci_ptr, COMMAND_NAME, "1.0", cu_$arg_list_ptr (), SSU_ABORT, code);
	if code ^= 0
	then do;
		call com_err_ (code, COMMAND_NAME, "Unable to create ssu invocation.");
		return;
	     end;


	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count ^= 2
	then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a LOG_PATH LOG_HISTORY_DIR_PATH", COMMAND_NAME);
	call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_lth);
	call expand_pathname_ (arg, log_dname, log_ename, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", arg);
	call initiate_file_ (log_dname, log_ename, RW_ACCESS, log_segment_ptr, (0), code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (log_dname, log_ename));
	if log_segment.version ^= LOG_SEGMENT_VERSION_1
	then call ssu_$abort_line (sci_ptr, 0,
		"The segment ^a is not a current version log segment or is seriously damaged.",
		pathname_ (log_dname, log_ename));
	call ssu_$arg_ptr (sci_ptr, 2, arg_ptr, arg_lth);
	call absolute_pathname_ (arg, log_history_dir, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", code);
	call hcs_$status_minf (log_history_dir, "", (1), type, (0), code);
	if code = 0 & type ^= 2
	then code = error_table_$notadir;
	if code = 0
	then yes = "1"b;
	else if code = error_table_$noentry
	then call command_query_$yes_no (yes, 0, COMMAND_NAME, "",
		"The directory ^a does not exist. Are you sure that you want to set it as the history dir?",
		log_history_dir);
	else if code ^= 0
	then call command_query_$yes_no (yes, code, COMMAND_NAME, "",
		"^a. Are you sure that you want to set it as the history directory?",
	          log_history_dir);
	if ^yes
	then call ssu_$abort_line (sci_ptr, 0, "History dir not changed.");
	log_segment.previous_log_dir = log_history_dir;
	call clean_up;
	return;

SSU_ABORT:
     procedure;
	go to ABORT_LABEL;
     end SSU_ABORT;

ABORT_LABEL:
	call clean_up;
	return;

clean_up:
     procedure;

	if log_segment_ptr ^= null ()
	then call terminate_file_ (log_segment_ptr, (0), TERM_FILE_TERM, (0));
	if sci_ptr ^= null ()
	then call ssu_$destroy_invocation (sci_ptr);
	return;
     end clean_up;

/* format: off */
%page; %include log_segment;
%page; %include access_mode_values;
%include terminate_file;

        end set_log_history_dir;




		    summarize_sys_log.pl1           03/01/89  1407.2rew 03/01/89  1356.7      369549



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

/* format: style2,indcomtxt */

ssl:
summarize_sys_log:
     procedure options (variable);

/**** This command scans a standard system log for specified text
      strings, writing information to pre-attached IO switches.

      A control file (in an archaic and incomprehensible format)
      controls what is written to the switches.

      Distribution of the output is controlled by the control file.
      This file has comment lines beginning with "*", and lines of the form

      .	streamname,S,opcode,text

      streamname	is the name of the stream on which a line will be written.
      S		Is the severity to be selected, in the form L:H
      .			*	selects all lines.
      opcode 	is the operation code (see below)
      text		is optional text which is the operand of opcode.

      Legal opcodes are:
      .	all	selects all lines at this severity
      .	any	selects all lines containing text
      .	begin	selects all lines beginning text
      .	not	inhibits all lines containing text
      .	nbegin	inhibits all lines beginning text
      .	count	counts all lines containing text
      .	bcount	counts all lines beginning text
      .	allx	same as all but binary data is expanded
      .	anyx	same as any but binary data is expanded
      .	beginx	same as begin, but binary data is expanded

      "not" and "nbegin" must precede any selectors they are to inhibit, for a given stream.

      At the end of processing, total lines are written. Then, if any lines were selected, a total count is output.

      THVV as daily_syserr_process
*/

/* Modified November 1975 by Larry Johnson for new syserr format */
/* Modified April 1976 by Larry Johnson to work correctly if first message read is "=" */
/* Modified September 1982 by E. N. Kittlitz to increase number of selectors and streams and check array bounds */
/* Modified 1984-12-03, BIM: converted to summarize_sys_log. */
/* Modified 1984-12-26, BIM: Added -continuation_indent. */
/* Modified 1985-02-21, Steve Herbst: Changed -dms to call dm_misc_util_$get_log_path */
/* Modified 1985-03-14, Steve Herbst: Fixed to recheck time range at end of find_first_message. Fixes bug where */
/*		if no messages within time range, procedure was getting the previous and next messages. */
/* Modified 1985-04-09, Steve Herbst: Fixed OOB caused by star-extent reference to switches_inhibited array */
/* Modified 1985-04-17, Steve Herbst: Fixed bug causing failure when using an already open output switch */
/* Modified 1985-05-02, Steve Herbst: Fixed to ensure from_time<=to_time. */


/****^  HISTORY COMMENTS:
  1) change(86-04-30,Kissel), approve(86-07-31,MCR7456), audit(86-08-01,Wong),
     install(86-11-03,MR12.0-1149):
     Modified to support DSA logs using the -dsasl and -dsasal control
     arguments.
  2) change(89-01-18,TLNguyen), approve(89-01-18,MCR8048),
     audit(89-02-23,RBarstad), install(89-03-01,MR12.3-1018):
     Fix the following errors:
        1. The -to control argument is ignored by summarize_sys_log.  The
           command processes the entry log from the date_time given in the
           -from control argument to the current date_time always.
        2. The command with no argument gets fault_tag_1.
                                                   END HISTORY COMMENTS */


	declare COMMAND_NAME	 char (32) int static init ("summarize_sys_log") options (constant);

	declare sci_ptr		 pointer;
	declare arg_count		 fixed bin;
	declare ap		 ptr;
	declare al		 fixed bin (21);
	declare arg		 char (al) based (ap);

	declare dm_system_log_path	 char (168);
	declare dsa_system_log_path	 char (168);
	declare code		 fixed bin (35);

	declare absolute_pathname_$add_suffix
				 entry (character (*), character (*), character (*), fixed binary (35));
	declare check_gate_access_	 entry (char (*), ptr, fixed bin (35));
	declare convert_date_to_binary_
				 entry (char (*), fixed bin (71), fixed bin (35));
	declare cu_$arg_list_ptr	 entry returns (pointer);
	declare com_err_		 entry () options (variable);
	declare cv_dec_check_	 entry (character (*), fixed binary (35)) returns (fixed binary (35));
	declare dm_misc_util_$get_log_path
				 entry (char (*));
	declare dsa_nit_$get_field	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	declare expand_pathname_	 entry (character (*), character (*), character (*), fixed binary (35));
	declare log_read_$open	 entry (character (*), character (*), pointer, fixed binary (35));
	declare log_read_$open_long	 entry (character (*), character (*), pointer, pointer, fixed binary (35));
	declare log_read_$free_message entry (pointer, pointer);
	declare log_read_$hold_message entry (pointer, pointer);
	declare log_read_$close	 entry (pointer, fixed binary (35));
	declare log_read_$next_message entry (pointer, pointer, fixed binary (35));
	declare log_read_$prev_message entry (pointer, pointer, fixed binary (35));
	declare format_log_message_$init
				 entry (pointer);
	declare format_log_message_$adjust
				 entry (pointer, fixed binary (35));
	declare format_log_message_$free
				 entry (pointer);
	declare format_log_message_$format
				 entry (pointer, pointer, pointer, character (*) var, character (*) var,
				 fixed binary (35));

	declare expand_log_message_	 entry (pointer, pointer, pointer, character (*) var, fixed binary (35));
	declare log_format_time_	 entry (fixed binary (71)) returns (character (32) var);
	declare log_limit_scan_	 entry (pointer, pointer, bit (1) aligned, pointer);

	declare log_match_$add_match	 entry (pointer, character (*));
	declare log_match_$add_severity
				 entry (pointer, fixed binary, fixed binary);
	declare log_match_$test	 entry (pointer, pointer, character (*) varying) returns (bit (1) aligned);
	declare log_match_$free	 entry (pointer);
	declare log_match_$print	 entry (pointer, pointer, fixed binary);

	declare ioa_		 entry options (variable);
	declare ioa_$ioa_switch	 ext entry options (variable);
	declare get_wdir_		 entry () returns (char (168));

	declare (addr, addwordno, after, before, hbound, index, length, ltrim, null, rtrim, substr, unspec)
				 builtin;


%include iox_entries;
%include iox_modes;
	declare pathname_		 entry (character (*), character (*)) returns (character (168));
	declare ssu_$arg_count	 entry (ptr, fixed bin);
	declare ssu_$get_area	 entry (ptr, ptr, char (*), ptr);
	declare ssu_$standalone_invocation
				 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	declare ssu_$destroy_invocation
				 entry (ptr);
	declare ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin (21));
	declare ssu_$abort_line	 entry () options (variable);
	declare ssu_$print_message	 entry () options (variable);
	declare ssu_$set_debug_mode	 entry (ptr, bit (1) aligned);

	declare unique_chars_	 entry (bit (*)) returns (char (15));

	declare log_data_$syserr_log_dir
				 char (168) external;
	declare log_data_$syserr_log_name
				 char (32) external;

	declare cleanup		 condition;

%include log_message;
%include log_message_format;
%include log_limit_info;
%include log_read_open_info;
	declare 1 log_open_info	 aligned like log_read_open_info;

	declare 1 opt		 aligned,
		2 log_read_ptr	 pointer,
		2 log_pathname	 char (168) unal,
		2 control_file_pathname
				 char (168) unal,
		2 limit		 aligned like log_limit_info,
		2 procedure	 char (32) unal,
		2 control_iocb	 pointer,
		2 long_sw		 bit (1) aligned,
		2 debug_sw	 bit (1) aligned;

	declare (
	        SYSERR_PATH		 init ("<<SYSERR>>"),
	        AS_PATH		 init ("<<AS>>"),
	        ADMIN_PATH		 init ("<<ADMIN>>"),
	        DM_PATH		 init ("<<DM>>"),
	        DSASL_PATH		 init ("<<DSASL>>"),
	        DSASAL_PATH		 init ("<<DSASAL>>")
	        )			 char (32) int static options (constant);

	declare 1 switches		 (1000) aligned,
		2 switch		 char (32) unal,
		2 prev_message_ptr	 pointer,
		2 iocb_ptr	 pointer,
		2 opened_here	 bit (1) aligned,	/* Opened by this program as a courtesy */
		2 message_count	 fixed bin,
		2 line_length	 fixed bin;

	declare 1 selectors		 (1000) aligned,
		2 switchx		 fixed bin,
		2 opcode		 fixed bin,
		2 match_ptr	 pointer,
		2 message_count	 fixed bin,
		2 exclude		 bit (1) aligned,	/* exclude all other selectors for the switch */
		2 expand		 bit (1) aligned;


	declare (n_switches, n_selectors)
				 fixed bin;

	declare line		 fixed bin;
	declare dir_name		 char (168);
	declare entryname		 char (32);
	declare buffer_space	 char (1000);
	declare buffer_length	 fixed bin (21);

	declare (
	        ALL		 init (1),
	        ANY		 init (2),
	        BEGIN		 init (3),
	        NOT		 init (4),
	        N_BEGIN		 init (5),
	        COUNT		 init (6),
	        B_COUNT		 init (7)
	        )			 fixed bin int static options (constant);
	declare DEFAULT_CONTROL_FILE	 char (32) init ("daily_report.ssl") int static options (constant);
	declare CONTROL_SUFFIX	 char (32) init ("ssl") int static options (constant);

	declare error_table_$not_attached
				 fixed bin (35) ext static;
	declare error_table_$end_of_info
				 fixed bin (35) ext static;
	declare error_table_$no_log_message
				 fixed bin (35) ext static;
	declare error_table_$bad_arg	 fixed bin (35) ext static;
	declare error_table_$badopt	 fixed bin (35) ext static;
	declare error_table_$moderr	 fixed bin (35) ext static;
	declare error_table_$noarg	 fixed bin (35) ext static;
	declare error_table_$noentry	 fixed bin (35) ext static;
	declare error_table_$too_many_args
				 fixed bin (35) ext static;
	declare error_table_$bad_conversion
				 fixed bin (35) ext static;


	declare DM_READER_PROCEDURE	 char (32) init ("dm_log_read_") int static options (constant);
	declare DSA_READER_PROCEDURE	 char (32) init ("dsa_log_admin_gate_") int static options (constant);



	sci_ptr = null ();
	log_message_format_ptr = null ();
	opt.log_read_ptr = null ();
	opt.control_iocb = null ();
	n_selectors, n_switches = 0;

	on cleanup call clean_up;

	call ssu_$standalone_invocation (sci_ptr, COMMAND_NAME, "1.0", cu_$arg_list_ptr (), SSU_ABORT, code);
	if code ^= 0
	then do;
		call com_err_ (code, COMMAND_NAME);
		return;
	     end;

	call ssu_$arg_count (sci_ptr, arg_count);
	if arg_count = 0
	then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a LOG_PATHNAME {-control_arguments}", COMMAND_NAME);

	call initialize_options;
	call process_arguments;

/**** Now find things */

/**** The log itself */

	call make_log_pathname;			/* pathname of log */

	if opt.procedure ^= ""
	then do;
		log_open_info.version = LOG_READ_OPEN_INFO_VERSION_1;
		log_open_info.reader_procedure = opt.procedure;
		call ssu_$get_area (sci_ptr, null (), "log_read_ copies", log_open_info.allocation_area_ptr);
		log_open_info.allocate_copies = "0"b;	/* That is the inner-ring's job */
		call log_read_$open_long (dir_name, entryname, addr (log_open_info), opt.log_read_ptr, code);
	     end;
	else call log_read_$open (dir_name, entryname, opt.log_read_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", opt.log_pathname);

	call read_control_file;

	call log_limit_scan_ (sci_ptr, addr (opt.limit), "0"b, opt.log_read_ptr);

	call find_first_message ();


	call print_limits (iox_$user_output, "1"b);

	call process_messages ();


	call clean_up;
	return;


clean_up:
     procedure;

	declare slx		 fixed bin;

	if opt.control_iocb ^= null ()
	then do;
		call iox_$close (opt.control_iocb, (0));
		call iox_$detach_iocb (opt.control_iocb, (0));
		call iox_$destroy_iocb (opt.control_iocb, (0));
	     end;

	if opt.log_read_ptr ^= null ()
	then call log_read_$close (opt.log_read_ptr, (0));
	if log_message_format_ptr ^= null ()
	then call format_log_message_$free (log_message_format_ptr);
	do slx = 1 to n_selectors;
	     if selectors (slx).match_ptr ^= null ()
	     then call log_match_$free (selectors (slx).match_ptr);
	end;
	do slx = 1 to n_switches;
	     if switches (slx).opened_here
	     then call iox_$close (switches (slx).iocb_ptr, (0));
	end;

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

	return;

     end clean_up;


make_log_pathname:
     procedure ();


	if (opt.log_pathname = SYSERR_PATH)
	then do;
		dir_name = log_data_$syserr_log_dir;
		entryname = log_data_$syserr_log_name;
		opt.log_pathname = pathname_ (dir_name, entryname);
	     end;

	else if opt.log_pathname = AS_PATH
	then do;
		dir_name = ">system_control_dir>as_logs";
		entryname = "log";
		opt.log_pathname = pathname_ (dir_name, entryname);
	     end;
	else if opt.log_pathname = ADMIN_PATH
	then do;
		dir_name = ">system_control_dir>as_logs";
		entryname = "admin_log";
		opt.log_pathname = pathname_ (dir_name, entryname);
	     end;
	else if opt.log_pathname = DM_PATH
	then do;
		call dm_misc_util_$get_log_path (dm_system_log_path);
		call expand_pathname_ (dm_system_log_path, dir_name, entryname, 0);
		opt.procedure = DM_READER_PROCEDURE;
		opt.log_pathname = dm_system_log_path;
	     end;
	else if opt.log_pathname = DSASL_PATH
	then do;

		/*** Check to see if we will succeed. */

		call check_gate_access_ (DSA_READER_PROCEDURE, null (), code);

		if code = error_table_$noentry
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "DSA is not installed on this system.");
		else if code = error_table_$moderr
		then call ssu_$abort_line (sci_ptr, code, "You need e access to ^a to read the DSA log.",
			DSA_READER_PROCEDURE);
		else if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Trying to check the access to: ^a.", DSA_READER_PROCEDURE);

		/*** The code was 0, proceed. */

		else call dsa_nit_$get_field ("mna_general_info", "", "dsa_system_log", dsa_system_log_path, code);

		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Cannot find the name of the dsa system log.");

		call expand_pathname_ (dsa_system_log_path, dir_name, entryname, 0);
		opt.procedure = DSA_READER_PROCEDURE;
		opt.log_pathname = dsa_system_log_path;
	     end;
	else if opt.log_pathname = DSASAL_PATH
	then do;

		/*** Check to see if we will succeed. */

		call check_gate_access_ (DSA_READER_PROCEDURE, null (), code);

		if code = error_table_$noentry
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "DSA is not installed on this system.");
		else if code = error_table_$moderr
		then call ssu_$abort_line (sci_ptr, code, "You need e access to ^a to read the DSA log.",
			DSA_READER_PROCEDURE);
		else if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Trying to check the access to: ^a.", DSA_READER_PROCEDURE);

		/*** The code was 0, proceed. */

		else call dsa_nit_$get_field ("mna_general_info", "", "dsa_system_aep_log", dsa_system_log_path, code)
			;

		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "Cannot find the name of the dsa system aep log.");

		call expand_pathname_ (dsa_system_log_path, dir_name, entryname, 0);
		opt.procedure = DSA_READER_PROCEDURE;
		opt.log_pathname = dsa_system_log_path;
	     end;

	else do;
		call expand_pathname_ (opt.log_pathname, dir_name, entryname, code);
		if (code ^= 0)
		then call ssu_$abort_line (sci_ptr, code, "Log pathname ^a", opt.log_pathname);
	     end;

	return;
     end make_log_pathname;


process_line:
     procedure;

	declare buffer		 char (buffer_length - 1) /* NO NL */ defined (buffer_space) pos (1);
	declare commax		 fixed bin (21);
	declare switch_name		 char (32);
	declare switchx		 fixed bin;
	declare 1 a_switch		 aligned like switches based (asp);
	declare asp		 pointer;
	declare 1 a_select		 aligned like selectors based (aslp);
	declare aslp		 pointer;
	declare match_text		 char (500) varying;
	declare new_commax		 fixed bin (21);
	declare (severity1, severity2) fixed bin;
	declare start_line		 bit (1) aligned;
	declare severity_string	 char (32);
	declare opcode_string	 char (32);
	declare text_required	 bit (1) aligned;

	line = line + 1;
	if substr (buffer, 1, 1) = "*"
	then return;

	commax = index (buffer, ",");
	if commax = 0
	then call ssu_$abort_line (sci_ptr, (0), "Error on line ^d: No comma after the switch name ^a.", line, buffer);
	if commax = 1
	then call ssu_$abort_line (sci_ptr, (0), "Error on line ^d:  Null switch name.", line);

	switch_name = ltrim (substr (buffer, 1, commax - 1));
	do switchx = 1 to n_switches;
	     if switch_name = switches (switchx).switch
	     then do;
		     asp = addr (switches (switchx));
		     go to FOUND_SWITCH;
		end;
	end;

/* switchx is now 1 past n_switches. */

	if switchx >= hbound (switches, 1)
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args,
		"Error on line ^d: Limit of ^d switches exceeded.", line, hbound (switches, 1));
	n_switches = switchx;

	asp = addr (switches (switchx));

	a_switch.switch = switch_name;
	a_switch.prev_message_ptr = null ();
	a_switch.opened_here = "0"b;			/* Until proven elsewise */
	call iox_$look_iocb (switch_name, a_switch.iocb_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Error on line ^d: Switch ^a not attached.", line, switch_name);
	a_switch.message_count = 0;
	call check_switch_state;

FOUND_SWITCH:
	if n_selectors = hbound (selectors, 1)
	then call ssu_$abort_line (sci_ptr, error_table_$too_many_args,
		"Error on line ^d: more than ^d selection lines.", line, hbound (selectors, 1));

	n_selectors = n_selectors + 1;
	aslp = addr (selectors (n_selectors));

	a_select.switchx = switchx;
	a_select.match_ptr = null ();
	a_select.message_count = 0;
	a_select.expand = "0"b;

/**** next we look for the severity */

	new_commax = index (substr (buffer, commax + 1), ",");
	if new_commax = 0
	then call ssu_$abort_line (sci_ptr, (0), "Error on line ^d: No comma after the severity for switch ^a.", line,
		switch_name);

	severity_string = substr (buffer, commax + 1, new_commax - 1);
	if length (severity_string) = 0
	then call ssu_$abort_line (sci_ptr, 0, "Error on line ^d: null severity.", line);
	commax = commax + new_commax;

	if severity_string = "*"
	then ;
	else do;					/* something here */
		severity1 = cv_dec_check_ (before (severity_string, ":"), code);
		if (code ^= 0)
		then
INVALID_SEVERITY_RANGE:
		     call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
			"Error on line ^d: Invalid severity value ""^a"": must be <N> or <N>:<M> or *", line,
			severity_string);

		if (index (severity_string, ":") = 0)
		then /* Not a range, just a single number */
		     severity2 = severity1;
		else severity2 = cv_dec_check_ (after (severity_string, ":"), code);
		if (code ^= 0)
		then goto INVALID_SEVERITY_RANGE;

		call log_match_$add_severity (a_select.match_ptr, severity1, severity2);

	     end;

/**** Next, the opcode */

	new_commax = index (substr (buffer, commax + 1), ",");

	if new_commax = 0
	then do;
		opcode_string = substr (buffer, commax + 1);
		commax = 0;			/* flag no text */
	     end;
	else do;
		opcode_string = substr (buffer, commax + 1, new_commax - 1);
		commax = commax + new_commax;
	     end;

	if opcode_string = ""
	then call ssu_$abort_line (sci_ptr, 0, "Error on line ^d: null opcode.", line);
	text_required = "0"b;
	a_select.exclude = "0"b;
	start_line = "0"b;
	if opcode_string = "all"
	then a_select.opcode = ALL;
	else if opcode_string = "any"
	then do;
		a_select.opcode = ANY;
		text_required = "1"b;
	     end;
	else if opcode_string = "begin"
	then do;
		a_select.opcode = BEGIN;
		text_required = "1"b;
		start_line = "1"b;
	     end;
	else if opcode_string = "not"
	then do;
		a_select.opcode = NOT;
		text_required = "1"b;
		a_select.exclude = "1"b;
	     end;
	else if opcode_string = "nbegin"
	then do;
		a_select.opcode = N_BEGIN;
		start_line = "1"b;
		a_select.exclude = "1"b;
		text_required = "1"b;
	     end;
	else if opcode_string = "count"
	then a_select.opcode = COUNT;
	else if opcode_string = "bcount"
	then do;
		a_select.opcode = B_COUNT;
		start_line = "1"b;
		text_required = "1"b;
	     end;
	else if opcode_string = "allx"
	then do;
		a_select.opcode = ALL;
		a_select.expand = "1"b;
	     end;
	else if opcode_string = "anyx"
	then do;
		a_select.opcode = ANY;
		a_select.expand = "1"b;
		text_required = "1"b;
	     end;
	else if opcode_string = "beginx"
	then do;
		a_select.opcode = BEGIN;
		a_select.expand = "1"b;
		text_required = "1"b;
		start_line = "1"b;
	     end;
	else call ssu_$abort_line (sci_ptr, 0, "Error on line ^d: Invalid opcode ^a.", line, opcode_string);


	if text_required & commax = 0
	then call ssu_$abort_line (sci_ptr, 0, "Error on line ^d: the opcode ^a requires a selector string.", line,
		opcode_string);


	if commax > 1
	then do;					/* add the match string */
		match_text = ltrim (rtrim (substr (buffer, commax + 1)));
		if start_line
		then do;
			match_text = "/^" || match_text;
			match_text = match_text || "/";
		     end;
		call log_match_$add_match (a_select.match_ptr, (match_text));
	     end;
	return;                                           /* return from process_line internal procedure */
%page;

/**** This procedure is not a "valid" use of iox_. However, there is
      really no better way to find out whether a switch is open.
      Doing I/O and looking at the return code is not reasonable. */

check_switch_state:
     procedure;

	if a_switch.iocb_ptr -> iocb.attach_data_ptr = null ()
	then call ssu_$abort_line (sci_ptr, error_table_$not_attached, "Error on line ^d: Switch ^a.", line,
		a_switch.switch);
	if a_switch.iocb_ptr -> iocb.open_descrip_ptr = null ()
	then do;
		a_switch.opened_here = "1"b;
		call iox_$open (a_switch.iocb_ptr, Stream_output, "0"b, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code,
			"Error on line ^d: Failed to open switch ^a for stream_output.", line, a_switch.switch);
	     end;
	return;                                           /* return from check_switch_state internal procedure */


%include iocb;


     end check_switch_state;

     end process_line;


process_arguments:
     procedure;

	declare argx		 fixed bin;
	declare v_log_ename		 char (32) varying;
	declare number_arg		 char (32) varying;
	declare temp_number		 fixed bin;
	declare (from_time, to_time)	 fixed bin (71);
	declare exchange_opt	 char (50) varying;
	declare code		 fixed bin (35);

	do argx = 1 to arg_count;
	     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
	     if index (arg, "-") ^= 1
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = arg;
		end;
	     else if (arg = "-syserr")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = SYSERR_PATH;
		end;

	     else if (arg = "-answering_service") | (arg = "-as")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = AS_PATH;
		end;
	     else if (arg = "-admin")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = ADMIN_PATH;
		end;
	     else if (arg = "-dm_system") | (arg = "-dms")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = DM_PATH;
		end;
	     else if (arg = "-dsa_sys_log") | (arg = "-dsasl")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = DSASL_PATH;
		end;
	     else if (arg = "-dsa_sys_aep_log") | (arg = "-dsasal")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     opt.log_pathname = DSASAL_PATH;
		end;
	     else if (arg = "-mc_log") | (arg = "-mcl")
	     then do;
		     if opt.log_pathname ^= ""
		     then call two_logs;
		     call get_next_arg (v_log_ename);
		     opt.log_pathname = pathname_ (">system_control_dir>as_logs", (v_log_ename));
		end;

	     else if (arg = "-from") | (arg = "-fm")
	     then call get_next_arg (opt.limit.from_opt);
	     else if (arg = "-last") | (arg = "-lt")
	     then call get_next_arg (opt.limit.last_opt);
	     else if (arg = "-to")
	     then call get_next_arg (opt.limit.to_opt);
	     else if (arg = "-for") | (arg = "-next")
	     then call get_next_arg (opt.limit.for_opt);


	     else if (arg = "-control")
	     then do;
		     if argx = arg_count
		     then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "-control must be followed by a control file pathname.");
		     argx = argx + 1;
		     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
		     opt.control_file_pathname = arg;
		end;

	     else if (arg = "-long") | (arg = "-lg")
	     then opt.long_sw = "1"b;
	     else if (arg = "-brief") | (arg = "-bf")
	     then opt.long_sw = "0"b;
	     else if (arg = "-debug") | (arg = "-db")
	     then do;
		     opt.debug_sw = "1"b;
		     call ssu_$set_debug_mode (sci_ptr, "1"b);
		end;
	     else if (arg = "-procedure") | (arg = "-proc")
	     then do;
		     if argx = arg_count
		     then call ssu_$abort_line (sci_ptr, error_table_$noarg,
			     "-procedure must be followed by a log reading procedure.");
		     argx = argx + 1;
		     call ssu_$arg_ptr (sci_ptr, argx, ap, al);
		     opt.procedure = arg;
		end;

	     else if (arg = "-number_format") | (arg = "-nfmt")
	     then do;
		     call get_next_arg (log_message_format.number_format);
		     call format_log_message_$adjust (log_message_format_ptr, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Processing -number_format",
			     log_message_format.number_format);
		end;

	     else if (arg = "-indent") | (arg = "-ind") | (arg = "-in")
	     then do;
		     call get_next_arg (number_arg);
		     log_message_format.indentation = cv_dec_check_ ((number_arg), code);
		     if (code ^= 0) | (log_message_format.indentation < 0) | (log_message_format.indentation > 50)
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
			     "Indentation must be between 0 and 50, not ^a", number_arg);

		     call format_log_message_$adjust (log_message_format_ptr, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Processing -indent ^a", number_arg);
		end;				/* Of -indent processing */
	     else if (arg = "-continuation_indent") | (arg = "-ci")
	     then do;
		     call get_next_arg (number_arg);
		     if number_arg = "std" | number_arg = "standard"
		     then log_message_format.continuation_indent = -1;
		     else do;
			     log_message_format.continuation_indent = cv_dec_check_ ((number_arg), code);
			     if (code ^= 0) | (log_message_format.continuation_indent < 0)
				| (log_message_format.continuation_indent > 50)
			     then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
				     "Continuation indent must be between 0 and 50 or ""standard"", not ^a",
				     number_arg);
			end;
		     call format_log_message_$adjust (log_message_format_ptr, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code,
			     "Failed to adjust log message format after processing -continuation_indent ^a.", arg);
		end;				/* Of -continuation_indent processing */


	     else if (arg = "-prefix") | (arg = "-pfx")
	     then do;
		     call get_next_arg (log_message_format.prefix);
		     call format_log_message_$adjust (log_message_format_ptr, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Error processing -prefix ^a",
			     log_message_format.prefix);
		end;				/* Of -prefix processing */


	     else if (arg = "-time_format") | (arg = "-tfmt")
	     then do;
		     call get_next_arg (log_message_format.time_format);
		     call format_log_message_$adjust (log_message_format_ptr, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, "Processing -time_format ^a", log_message_format.time_format)
			     ;
		end;

	     else if (arg = "-date_format") | (arg = "-dfmt")
	     then do;
		     call get_next_arg (log_message_format.date_format);
		     call format_log_message_$adjust (log_message_format_ptr, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Processing -date_format ^a",
			     log_message_format.date_format);
		end;

	     else call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
	end;


/**** Okay, do we have some needful args? */

	if opt.log_pathname = ""
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Usage: ^a LOG_PATHNAME -control_args", COMMAND_NAME);

/* Make sure the -from time is less than the -to time */

	if opt.limit.from_opt ^= "" & opt.limit.to_opt ^= ""
	then do;
		temp_number = cv_dec_check_ ((opt.limit.from_opt), code);
		if code ^= 0
		then do;
			temp_number = cv_dec_check_ ((opt.limit.to_opt), code);
			if code ^= 0
			then do;
				call convert_date_to_binary_ ((opt.limit.from_opt), from_time, 0);
				call convert_date_to_binary_ ((opt.limit.to_opt), to_time, 0);
				if from_time > to_time
				then do;
					exchange_opt = opt.limit.from_opt;
					opt.limit.from_opt = opt.limit.to_opt;
					opt.limit.to_opt = exchange_opt;
				     end;
			     end;
		     end;
	     end;

	return;                       /* complete process_arguments procedure */

%page;
/* the following procedures are internal to the process_arguments procedure */

/*-------------------- get_next_arg internal procedure -------------------- */
get_next_arg:
     procedure (P_option);

	declare P_option		 char (*) varying parameter;


	if (argx >= arg_count)
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Value missing after ^a", arg);

	argx = argx + 1;
	call ssu_$arg_ptr (sci_ptr, argx, ap, al);

	P_option = arg;

	return;
     end get_next_arg;

/*---------------------- two_logs internal procedure ---------------------- */
two_logs:
     procedure;

	call ssu_$abort_line (sci_ptr, 0, "More than one log was specified on the input line.  ""^a"" was the second log.", arg);

	return;
     end two_logs;

/* complete all internal procedures which are called by process_arguments */

     end process_arguments;

%page;
initialize_options:
     procedure;


	opt.control_iocb, opt.log_read_ptr = null ();
	opt.long_sw = "0"b;
	opt.debug_sw = "0"b;
	opt.log_pathname, opt.control_file_pathname = "";
	opt.control_file_pathname = pathname_ (get_wdir_ (), DEFAULT_CONTROL_FILE);
	opt.limit.version = LOG_LIMIT_INFO_VERSION_1;
	opt.limit.to_opt = "";			/* Set up to call the limit scanner */
	opt.limit.from_opt = "";
	opt.limit.for_opt = "";
	opt.limit.last_opt = "";
	opt.procedure = "";
	call format_log_message_$init (log_message_format_ptr);
	log_message_format.caller = COMMAND_NAME;
	log_message_format.line_lth = 132;
	log_message_format.indentation = 0;
	log_message_format.equal_sw = "0"b;
	log_message_format.error_sw = "1"b;
	log_message_format.prefix = "";
	call format_log_message_$adjust (log_message_format_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to adjust initial log message format.");

	return;
     end initialize_options;

%page;
read_control_file:
     procedure;
	declare control_iocb_name	 char (32);

	call absolute_pathname_$add_suffix ((opt.control_file_pathname), CONTROL_SUFFIX, opt.control_file_pathname,
	     code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", opt.control_file_pathname);

	control_iocb_name = "summarize_sys_log" || unique_chars_ (""b);
	call iox_$attach_name (control_iocb_name, opt.control_iocb, "vfile_ " || opt.control_file_pathname, null (),
	     code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to attach ^a", opt.control_file_pathname);
	call iox_$open (opt.control_iocb, Stream_input, "0"b, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "Failed to open ^a", opt.control_file_pathname);

	n_switches, n_selectors = 0;

	code = 0;
	line = 0;
	do while (code ^= error_table_$end_of_info);
	     call iox_$get_line (opt.control_iocb, addr (buffer_space), length (buffer_space), buffer_length, code);
	     if code = 0
	     then call process_line;
	     else if code ^= error_table_$end_of_info
	     then do;
		     line = line + 1;		/* we skipped a line */
		     call ssu_$print_message (sci_ptr, code, "Error reading line ^d.", line);
		end;
	end;

	call iox_$close (opt.control_iocb, (0));
	call iox_$detach_iocb (opt.control_iocb, (0));
	call iox_$destroy_iocb (opt.control_iocb, (0));
	opt.control_iocb = null ();

	call ioa_ ("^a: ^d streams, ^d selectors", COMMAND_NAME, n_switches, n_selectors);

	if n_selectors = 0 | n_switches = 0
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
		"There must be at least one switch and at least one selctor.");
	return;
     end read_control_file;

%page;
print_limits:
     procedure (iocb, identify);

	declare iocb		 pointer;
	declare identify		 bit (1) aligned;

	if (opt.first_msg = null ())
	then call ioa_$ioa_switch (iocb, "^[^a ^;^s^]Log ^a to ^a", identify, COMMAND_NAME, opt.log_pathname,
		log_format_time_ ((opt.last_msg -> log_message.time)));

	else if (opt.last_msg = null ())
	then call ioa_$ioa_switch (iocb, "^[^a: ^;^s^]Log ^a from ^a", identify, COMMAND_NAME, opt.log_pathname,
		log_format_time_ ((opt.first_msg -> log_message.time)));
	else call ioa_$ioa_switch (iocb, "^[^a: ^;^s^]Log ^a from ^a to ^a", identify, COMMAND_NAME, opt.log_pathname,
		log_format_time_ ((opt.first_msg -> log_message.time)),
		log_format_time_ ((opt.last_msg -> log_message.time)));

	return;
     end print_limits;


find_first_message:
     procedure ();

	declare total_count		 fixed bin;
	declare hold_message_sw	 bit (1);

	total_count = 0;

/* This procedure locates the message we're going to start with, in case we're
   doing something like "-last 10", where log_limit_scan_ can't determine the
   real starting point because it might depend (if we had -match) on message
   content. */

	hold_message_sw = "0"b;
	if (opt.first_msg ^= null ())
	then /* We know where we're starting */
	     go to FOUND;

/* Otherwise, we look backwards to find where to start.  We are guaranteed,
   by log_limit_scan_, that at least one limit is non-null, and also that if
   one is null, there is a limit count. If, however, we run out of messages
   before we hit the limit, that's still OK, and we print all that we have. */

	log_message_ptr = opt.last_msg;

	do total_count = 1 by 1 while (total_count < opt.msg_count);

	     call log_read_$prev_message (opt.log_read_ptr, log_message_ptr, code);
	     if (code ^= 0)
	     then do;
		     if code = error_table_$no_log_message
		     then log_message_ptr = null ();
		     else call ssu_$abort_line (sci_ptr, code,
			     "Internal error: Failed to find message before message ^p.", log_message_ptr);
		end;
	     if (log_message_ptr = null ())
	     then /* If we've run out, terminate the loop */
		total_count = opt.msg_count;
	end;

	if (log_message_ptr = null ())
	then
NO_MESSAGES:
	     call ssu_$abort_line (sci_ptr, 0, "No messages matched criteria. ^d message^[s^] read.", total_count,
		(total_count ^= 1));

	opt.first_msg = log_message_ptr;
	hold_message_sw = "1"b;

FOUND:
	if hold_message_sw
	then call log_read_$hold_message (opt.log_read_ptr, opt.first_msg);
	return;
     end find_first_message;


process_messages:
     procedure;

/* Following code is the processing loop on log entries.
   Each line is checked against all selectors to see if it should be written. */
	declare total_messages	 fixed bin (35);
	declare slx		 fixed bin;
	declare s_iocb		 pointer;

	total_messages = 0;

	do slx = 1 to n_switches;
	     call print_limits (switches (slx).iocb_ptr, "0"b);
	     call ioa_$ioa_switch (switches (slx).iocb_ptr, "");
	end;

	if opt.long_sw
	then call ioa_ ("^/SUMMARY OF SELECTORS:^/");
	do slx = 1 to n_selectors;
	     if opt.long_sw
	     then do;
		     call ioa_ ("^3d ^a ^[all^;any^;begin^;not^;nbegin^;count^;bcount^]^[x^]", slx,
			switches (selectors (slx).switchx).switch, selectors (slx).opcode, selectors (slx).expand);
		     if selectors (slx).match_ptr ^= null ()
		     then call log_match_$print (selectors (slx).match_ptr, iox_$user_output, 5);
		end;

	     s_iocb = switches (selectors (slx).switchx).iocb_ptr;
	     call ioa_$ioa_switch (s_iocb, "^/^3d  ^a ^[all^;any^;begin^;not^;nbegin^;count^;bcount^]^[x^]", slx,
		switches (selectors (slx).switchx).switch, selectors (slx).opcode, selectors (slx).expand);
	     if selectors (slx).match_ptr ^= null ()
	     then call log_match_$print (selectors (slx).match_ptr, s_iocb, 5);
	     else call ioa_$ioa_switch (s_iocb, "^5xAll severities.");
	     call ioa_$ioa_switch (s_iocb, "");
	end;


	log_message_ptr = opt.first_msg;
	do while (log_message_ptr ^= null ());   /* Catch running out of messages */
                                                   /* determine whether the current message matches selection criteria. */
                                                   /* If it matches then print it out. */
	     call process_log_message;

                                                   /* Determine whether the specified last message (-to TIME, -to NUMBER) has been reached. */
	     if log_message_ptr = opt.last_msg
	     then log_message_ptr = null;        /* indicates that all requested messages are completely processed. */
	     else do;                            /* The -to control argument is not specified. */
                                                   /* so continue to process all remaining messages in the log ( by default) */
		     call log_read_$next_message (opt.log_read_ptr, log_message_ptr, code);
		     if code ^= 0
		     then do;
                                                   /* terminate the do while loop */
			     log_message_ptr = null ();

		               if code ^= error_table_$no_log_message
		               then call ssu_$print_message (sci_ptr, code, "Reading next message.");
		          end;
	         end;
	end;                                    /* process all mesages in the log */


	/*** Skip lines on all switches */

	do slx = 1 to n_switches;
	     call ioa_$ioa_switch (switches (slx).iocb_ptr, "");
	end;

/**** Write summary lines for selectors */

	do slx = 1 to n_selectors;
	     if selectors (slx).opcode = COUNT | selectors (slx).opcode = B_COUNT
	     then do;
		     call ioa_$ioa_switch (switches (selectors (slx).switchx).iocb_ptr, "^d messages:",
			selectors (slx).message_count);
		     call log_match_$print (selectors (slx).match_ptr, switches (selectors (slx).switchx).iocb_ptr,
			5 /* indent */);
		end;
	end;

/**** Write  summary for stream */

	do slx = 1 to n_switches;
	     call ioa_$ioa_switch (switches (slx).iocb_ptr, "^/TOTAL: ^d written.", switches (slx).message_count);
	end;

	call ioa_ ("summarize_sys_log: ^d messages read.", total_messages);
	return;                                           /* return from process_messages internal procedure */


process_log_message:
     procedure;
	declare text_buffer		 char (5000) varying;
	declare expand_buffer	 char (5000) varying;
	declare slx		 fixed bin;
	declare test_sw		 bit (1) aligned;
	declare switches_inhibited	 (1000) bit (1) unaligned;

	total_messages = total_messages + 1;
	unspec (switches_inhibited) = "0"b;		/* no NOTs yet */
	do slx = 1 to n_selectors;
	     if switches_inhibited (selectors (slx).switchx)
	     then call SKIP_SELECT;
	     if selectors (slx).match_ptr ^= null ()
	     then do;
		     test_sw = log_match_$test (selectors (slx).match_ptr, log_message_ptr, "");
		     if selectors (slx).exclude
		     then do;
			     if test_sw
			     then switches_inhibited (selectors (slx).switchx) = "1"b;
			     call SKIP_SELECT;
			end;
		     else if ^test_sw
		     then call SKIP_SELECT;
		end;

	     selectors (slx).message_count = selectors (slx).message_count + 1;
	     expand_buffer = "";
	     if selectors (slx).expand
	     then call expand_log_message_ (log_message_format_ptr, log_message_ptr, null (), expand_buffer, code);

	     call format_log_message_$format (log_message_format_ptr, log_message_ptr,
		switches (selectors (slx).switchx).prev_message_ptr, expand_buffer, text_buffer, (0));

	     call iox_$put_chars (switches (selectors (slx).switchx).iocb_ptr, addwordno (addr (text_buffer), 1),
		length (text_buffer), (0));

	     if switches (selectors (slx).switchx).prev_message_ptr ^= null ()
	     then call log_read_$free_message (opt.log_read_ptr, switches (selectors (slx).switchx).prev_message_ptr);
	     call log_read_$hold_message (opt.log_read_ptr, log_message_ptr);
	     switches (selectors (slx).switchx).prev_message_ptr = log_message_ptr;
	     switches (selectors (slx).switchx).message_count = switches (selectors (slx).switchx).message_count + 1;

SKIP_SELECTOR:
	end;


SKIP_SELECT:
     procedure;
	go to SKIP_SELECTOR;
     end SKIP_SELECT;


     end process_log_message;

     end process_messages;


SSU_ABORT:
     procedure;
	call clean_up;
	go to ABORT;
     end SSU_ABORT;
ABORT:
	return;

     end summarize_sys_log;







		    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