



		    PNOTICE_xmail.alm               11/14/89  1124.8r w 11/14/89  1124.7        2448



	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	56			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1989"

	aci	"C1EMSM0E0000"
	aci	"C2EMSM0E0000"
	aci	"C3EMSM0E0000"
	end




		    xmail.pl1                       09/02/88  0759.6rew 09/02/88  0735.8      240804



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


/****^  HISTORY COMMENTS:
  1) change(85-12-23,LJAdams), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-12 JG Backs: Changed the "Do you wish to continue? (y/n)" message
     to "Do you still wish to enter executive_mail?" for clarity when there
     are no messages in the incoming mailbox.  Took out constants YES and NO
     and literals of "yes" and "no".  Replaced by the include file
     xmail_responses.incl.pl1.
     85-04-17 JG Backs: Replaced all the Message Facility commands
     (accept_messages, defer_messages, print_messages) with calls to the new
     xmail_im_mgr_ module which uses the new Message Facility entrypoints for
     these functions.
     85-04-18 JG Backs: Added code to check new personalization option
     confirm_print_yn, set default to yes, and set the flag in xmail_data.
  2) change(85-12-23,LJAdams), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Added initialization of xmail_data.general_help switch.
  3) change(86-02-27,Blair), approve(86-02-27,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Change the auto_xmail_data structure to refere to the value seg pathname
     rather than the value seg ptr.  This change is being made so that the
     structure is initiated each time it is used and we don't have to worry
     about having an invalid pointer.
  4) change(87-01-19,Blair), approve(87-02-05,MCR7618),
     audit(87-04-14,RBarstad), install(87-04-26,MR12.1-1025):
     Check the total_messages in mailbox, not just ordinary ones so we'll
     have the ability to treat interactive msgs as mail.
  5) change(88-06-28,Blair), approve(88-07-27,MCR7959),
     audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098):
     Initialize the fkey_data_ptr to null before we enable the cleanup handler
     to avoid out_of_bounds error if we go through the handler before the ptr
     is set.
     Add code to the cleanup procedure to check for whether the xmail.error
     segment is in the pdir.  If so, and if its' bit_count is greater than 0,
     then warn the user that it exists.  XServices error-list #153.
                                                   END HISTORY COMMENTS */


xmail:
executive_mail: proc ();

/* BEGIN DESCRIPTION

function: This is the main executive mail procedure.  It sets up the user's
          xmail directory, the video system, interactive message handling
          and all data structures that are shared among the various xmail
          routines. It then calls the first menu. 

comments: Throughout xmail, the calls to the Message Facility's commands
          (accept_messages, print_messages, etc) should be changed to calls
          to the new entrypoints as soon as it is practical.

history:         Written by S. Krupp 12/14/81 

   83-06-21  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes. Added -nim/-im (undocumented) to disable/enable the interactive
   message handling. This option should eventually be available from the
   personalize menu as suggested by phx12801. 

   83-09-14 DJ Schimke: Modified the error output from a bad control arg to 
   print the arg as well as the help message. phx13258 

   83-09-18 DJ Schimke: Modified xmail's cleanup handler to do a much better 
   job and avoid the cleanup window that existed. phx15800 phx13944
   Also added ssu_$record_usage call so the new version's use can be 
   monitored.

   83-10-05 DJ Schimke: Modified to call xmail_get_str_$yes_no rather than
   rolling its own question code. Since xmail_get_str_ uses command_query_,
   users who wish to enter xmail regardless of the fact that they have no 
   incoming mail may use answer to bypass this question. phx 15963

   83-11-04 DJ Schimke: Added undocumented control arg "-escape_sequences"
   ("-esc" for short) to control the use of escape sequences when function 
   keys are available (intended primarily for debugging purposes). 

   83-12-07 DJ Schimke: Added cleanup for the ssu invocation and fixed the
   ssu_exit entry to do nothing.

   84-09-06 JG Backs: Modified  to check for personalization options and
   set flags after call to xmail_dir_manager_$open_dir and before control
   arguments are checked.  Added checks for new personalization options:
   Display Lists As Menus, Process Interactive Messages, Always Use Escape
   Keys, Multics Command Mode.

   84-09-18 JG Backs: Modified code to make internal procedure default_fkeys
   into a separate xmail module which can be called from both xmail.pl1 and
   xmail_Review_Defaults_.pl1.  This allows function key information to be
   changed during processing.  Also modified cleanup to free ptr to function
   key data.

   84-09-24 JG Backs: Added "-brief" control argument to print_messages 
   command so the message "You have no messages" would not print. This is to
   make xmail compatible with the new message facility for mr11.

   84-10-09 JG Backs: Added a test to make sure the function_key_data_ptr
   is not null before attempting to free it, in preparation for setting up
   the default function keys.

   84-10-20 JG Backs: Modified processing of control arguments to include
   messages to the user that indicate the control argument is obsolete, but
   will be supported for MR11 release, and to please use the personalization
   options.

   84-11-04 JG Backs: Added a trailing underscore to the name of external
   procedure xmail_default_fkeys_ to coincide with the name change of that
   module.  Audit change.

   84-11-13 JG Backs: Added a 1 bit input parameter "condition_signalled"
   to internal CLEANUP proc, which is "1" if procedure is called during
   cleanup condition and "0" all other times.  This bit is tested to prevent
   any screen output during a true cleanup condition.  The call and
   declaration of xmail_window_manager_$destroy_windows was also modified
   to include an input parameter, to indicate if screen output should be
   avoided.

   84-11-28 JG Backs: Added code in the CLEANUP internal procedure to
   reset the user_io modes "more_mode=fold" if it had been previously set
   by xmail to "more_mode=wrap" in the main procedure.  The code to set
   wrap mode had been present for a long time, but did not cause any
   problems until a change was made to xmail to let the user-specified
   modes be allowed within xmail.  Also changed the initializing of the
   old_modes variable from within the declaration to a statement.  TR18542.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     answer_yn		 char (3) var;	/* answer of yes or no */
	dcl     arg_index		 fixed bin;
	dcl     arg_len		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     bit_count              fixed bin (35);
	dcl     code		 fixed bin (35);
	dcl     interactive_msgs_yn	 bit (1) aligned;
	dcl     lifetime_first_invocation char (3) var;
	dcl     messages_need_cleanup	 bit (1) aligned;
	dcl     multics_yn		 bit (1) aligned;
	dcl     no_of_args		 fixed bin;
	dcl     old_modes		 char (256);
	dcl     xmail_dir_opened	 bit (1) aligned;
	dcl     (total_message_count, ordinary_message_count ) fixed bin;
	dcl     person		 char (32);
	dcl     project		 char (32);
	dcl     prompt_string	 char (160) var;
	dcl     reason		 char (128);
	dcl     sci_ptr		 ptr;
	dcl     use_default_fkeys	 bit (1) aligned;
	dcl     video_needs_cleanup	 bit (1) aligned;
	dcl     video_was_on	 bit (1) aligned;
	dcl     yes_sw		 bit (1) aligned;

	dcl     1 auto_xmail_data	 like xmail_data;
	dcl     1 ti		 like terminal_info;

/* BASED */

	dcl     arg		 char (arg_len) based (arg_ptr);

/* BUILTINS */

	dcl     (addr, bin, codeptr, index, null, rtrim) builtin;

/* CONDITIONS */

	dcl     (cleanup, program_interrupt, quit) condition;

/* ENTRIES */

          dcl     adjust_bit_count_      entry (char(168), char(32), bit(1) aligned, fixed bin(35), fixed bin(35));
	dcl     com_err_		 entry () options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
          dcl     get_pdir_              entry() returns(char(168));
          dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$modes		 entry (ptr, char (*), char (*), fixed bin (35));
	dcl     mail_system_$get_message_counts entry (char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$record_usage	 entry (ptr, ptr, fixed bin (35));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     ttt_info_$function_key_data entry (char (*), ptr, ptr, fixed bin (35));
	dcl     user_info_$whoami	 entry (char (*), char (*), char (*));
	dcl     video_utils_$turn_off_login_channel entry (fixed bin (35));
	dcl     video_utils_$turn_on_login_channel entry (fixed bin (35), char (*));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     xmail$ssu_exit	 entry ();
	dcl     xmail_Executive_Mail_	 entry ();
	dcl     xmail_Getting_Started_ entry ();
	dcl     xmail_default_fkeys_	 entry () returns (ptr);
	dcl     xmail_dir_manager_$close_dir entry options (variable);
	dcl     xmail_dir_manager_$open_dir entry (fixed bin (35));
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_im_mgr_$defer_messages entry ();
	dcl     xmail_im_mgr_$init     entry ();
	dcl     xmail_im_mgr_$print_messages entry ();
	dcl     xmail_im_mgr_$restore_original entry ();
	dcl     xmail_review_defers_	 entry (char (*), char (*), fixed bin);
	dcl     xmail_sw_$initialize	 entry ();
          dcl     xmail_value_$get_no_validate entry (char (*), char (*) var, fixed bin (35));
	dcl     xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35));
	dcl     xmail_value_$set	 entry (char (*), char (*) var, char (*) var, fixed bin (35));
	dcl     xmail_window_manager_$create_windows entry (fixed bin (35));
	dcl     xmail_window_manager_$destroy_windows entry (bit (1));

/* EXTERNAL STATIC */

	dcl     error_table_$badopt	 fixed bin (35) ext static;
	dcl     error_table_$invalid_device fixed bin (35) ext static;
	dcl     error_table_$no_table	 fixed bin (35) ext static;
	dcl     iox_$user_io	 ptr ext static;
	dcl     video_data_$terminal_iocb ptr ext static;
	dcl     xmail_err_$exit_now	 fixed bin (35) ext static;
	dcl     xmail_err_$insuff_room_for_xmail fixed bin (35) ext static;

/* CONSTANTS */

	dcl     ALWAYS_ESCAPE	 char (21) init ("always_escape_keys_yn") int static options (constant);
	dcl     CONFIRM_PRINT	 char (16) init ("confirm_print_yn") int static options (constant);
          dcl     ERROR_LOG_SEGMENT      char (11) init ("xmail.error") int static options (constant);
	dcl     FOLD_MODE		 char (14) init ("more_mode=fold") int static options (constant);
	dcl     HELP_LINE		 char (36) init ("If you need help, type ""help xmail"".") int static options (constant);
	dcl     INT_ERR		 char (38) init ("This is an internal programming error.") int static options (constant);
	dcl     INTERACTIVE_MSGS	 char (19) init ("interactive_msgs_yn") int static options (constant);
	dcl     LISTS_AS_MENUS	 char (17) init ("lists_as_menus_yn") int static options (constant);
	dcl     MIN_LINES_NEEDED	 fixed bin init (20) int static options (constant);
          dcl     MSGS_AS_MAIL           char (15) init ("msgs_as_mail_yn") int static options (constant);
	dcl     MULTICS_MODE	 char (15) init ("multics_mode_yn") int static options (constant);
	dcl     NAME		 char (14) init ("executive_mail") int static options (constant);
	dcl     N_FKEYS_USED	 fixed bin init (7) int static options (constant);
	dcl     PERSONALIZE_STATEMENT	 char (139) init ("^/  It will be supported in the MR11 release.^/  The Personalize Executive Mail menu can be used to set this function.^/Continuing setup...") int static options (constant);
	dcl     REMOVE_MENUS	 char (15) init ("remove_menus_yn") int static options (constant);
	dcl     WRAP_MODE		 char (14) init ("more_mode=wrap") int static options (constant);

/* INCLUDE FILES */

%include function_key_data;
%page;
%include terminal_info;
%page;
%include query_info;
%page;
%include xmail_data;
%page;
%include xmail_responses;
%page;
%include xmail_windows;
%page;

/* BEGIN*/

/* Make sure that xmail is not being recursively invoked. */

	if xmail_data_ptr ^= null
	then do;
	     call com_err_ (0, NAME, "Previous invocation still active.");
	     goto EXIT;
	end;

/* Establish cleanup handler */

	xmail_data_ptr = null ();
	sci_ptr = null ();
	xmail_dir_opened = "0"b;
	video_needs_cleanup = "0"b;
	messages_need_cleanup = "0"b;
	old_modes = "";
	on condition (cleanup) call CLEANUP ("1"b);	/* signal condition */

/* Log usage (ignoring any errors) */

	call ssu_$standalone_invocation (sci_ptr, NAME, (xmail_version), null (), xmail$ssu_exit, code);
	call ssu_$record_usage (sci_ptr, codeptr (xmail), code);
	call ssu_$destroy_invocation (sci_ptr);

/***** Init common data structures. *****/

	auto_xmail_data.mail_dir = "";
	auto_xmail_data.first_label = MAIN_MENU;
	auto_xmail_data.quit_label = QUIT;
	auto_xmail_data.value_seg_pathname = "";
	auto_xmail_data.function_key_data_ptr = null;

/* Get person name and project. */

	call user_info_$whoami (person, project, "");
	auto_xmail_data.person = rtrim (person);
	auto_xmail_data.project = rtrim (project);

	xmail_data_ptr = addr (auto_xmail_data);

/* Set up xmail directory. */
	auto_xmail_data.error_seg_in_pdir = "0"b;
	call xmail_dir_manager_$open_dir (code);
	if code = xmail_err_$exit_now then do;
	     call xmail_dir_manager_$close_dir ();
	     xmail_data_ptr = null;
	     goto EXIT;
	end;
	else if code ^= 0
	then goto COMPLAIN;
	xmail_dir_opened = "1"b;			/* for cleanup */

/* Check for personalization options first and set defaults & flags */

	call xmail_value_$get_no_validate (ALWAYS_ESCAPE, answer_yn, code);
	if code = 0 & answer_yn = YES
	then use_default_fkeys = "1"b;
	else use_default_fkeys = "0"b;

	call xmail_value_$get_no_validate (MULTICS_MODE, answer_yn, code);
	if code = 0 & answer_yn = YES
	then multics_yn = "1"b;
	else multics_yn = "0"b;

	call xmail_value_$get_no_validate (LISTS_AS_MENUS, answer_yn, code);
	if code = 0 & answer_yn = YES
	then auto_xmail_data.lists_as_menus = "1"b;
	else auto_xmail_data.lists_as_menus = "0"b;

	call xmail_value_$get_no_validate (INTERACTIVE_MSGS, answer_yn, code);
	if code = 0 & answer_yn = NO
	then interactive_msgs_yn = "0"b;
	else interactive_msgs_yn = "1"b;

	call xmail_value_$get_no_validate (REMOVE_MENUS, answer_yn, code);
	if code = 0 & answer_yn = YES
	then auto_xmail_data.remove_menus = "1"b;
	else auto_xmail_data.remove_menus = "0"b;

	call xmail_value_$get_no_validate (CONFIRM_PRINT, answer_yn, code);
	if code = 0 & answer_yn = NO
	then auto_xmail_data.confirm_print = "0"b;
	else auto_xmail_data.confirm_print = "1"b;

	call xmail_value_$get_no_validate (MSGS_AS_MAIL, answer_yn, code);
	if code = 0 & answer_yn = YES
	then auto_xmail_data.msgs_as_mail = "1"b;
	else auto_xmail_data.msgs_as_mail = "0"b;

/* Initialize general help switch and foreign mailbox switch					*/
	auto_xmail_data.general_help, auto_xmail_data.foreign_mailbox = "0"b;

/* Now check control arguments which can overide the settings for this
   invocation of xmail.  Also print obsolete warning message. */

	call cu_$arg_count (no_of_args, code);
	if code ^= 0
	then goto COMPLAIN;

	if no_of_args > 0
	then do arg_index = 1 to no_of_args;
		call cu_$arg_ptr (arg_index, arg_ptr, arg_len, code);
		if code ^= 0
		then goto COMPLAIN;

		if arg = "-mm" | arg = "-multics_mode"
		then do;
		     multics_yn = "1"b;
		     call ioa_ ("Control argument ""-multics_mode"" is now obsolete." || PERSONALIZE_STATEMENT);
		     call timer_manager_$sleep (5, "11"b);
		end;

		else if arg = "-nim" | arg = "-no_interactive_messages"
		then do;
		     interactive_msgs_yn = "0"b;
		     call ioa_ ("Control argument ""-no_interactive_messages"" is now obsolete." || PERSONALIZE_STATEMENT);
		     call timer_manager_$sleep (5, "11"b);
		end;

		else if arg = "-im" | arg = "-interactive_messages"
		then do;
		     interactive_msgs_yn = "1"b;
		     call ioa_ ("Control argument ""-interactive_messages"" is now obsolete." || PERSONALIZE_STATEMENT);
		     call timer_manager_$sleep (5, "11"b);
		end;

		else if arg = "-esc" | arg = "-escape_sequences"
		then do;
		     use_default_fkeys = "1"b;
		     call ioa_ ("Control argument ""-escape_sequences"" is now obsolete." || PERSONALIZE_STATEMENT);
		     call timer_manager_$sleep (5, "11"b);
		end;
		else do;
		     call com_err_ (error_table_$badopt, NAME, "^a^/^a", arg, HELP_LINE);
		     xmail_data_ptr = null;
		     goto EXIT;
		end;
	     end;

	auto_xmail_data.multics_mode = multics_yn;
	auto_xmail_data.interactive_msgs = interactive_msgs_yn;

/* Check number of messages to decide if continuing */

	call mail_system_$get_message_counts ((xmail_data.mail_dir), "incoming", "1"b, total_message_count, ordinary_message_count, (0), code); /* ignore code */
	if total_message_count < 1
	then do;
	     call ioa_$rsnnl ("^/You have no messages in the ""incoming"" mailbox.^/Do you still wish to enter executive_mail?", prompt_string, (0));
	     call xmail_get_str_$yes_no (prompt_string, yes_sw);
	     if ^yes_sw
	     then do;
		call xmail_dir_manager_$close_dir ();
		xmail_data_ptr = null;
		goto EXIT;
	     end;
	end;


/* Get terminal data (function keys etc.). */

	auto_xmail_data.n_fkeys_used = N_FKEYS_USED + bin (auto_xmail_data.multics_mode, 1, 0);

	ti.version = terminal_info_version;
	call iox_$control (iox_$user_io, "terminal_info", addr (ti), code);
	if code ^= 0
	then goto COMPLAIN;

	call ttt_info_$function_key_data (ti.term_type, null, function_key_data_ptr, code);
	if code ^= 0
	then use_default_fkeys = "1"b;
	else if function_key_data.highest < auto_xmail_data.n_fkeys_used
	then use_default_fkeys = "1"b;

	if use_default_fkeys
	then do;
	     if function_key_data_ptr ^= null ()
	     then free function_key_data_ptr -> function_key_data;
	     auto_xmail_data.function_key_data_ptr = xmail_default_fkeys_ ();
	     auto_xmail_data.normal_usage = "(For help, press ESC, then ""?"")";
	end;
	else do;
	     auto_xmail_data.function_key_data_ptr = function_key_data_ptr;
	     auto_xmail_data.normal_usage = "(For help, press F1)";
	end;



/* Window info */

	xmail_windows.min_lines_needed = MIN_LINES_NEEDED;/* For now. */
	xmail_windows.status.iocb,
	     xmail_windows.menu.iocb,
	     xmail_windows.bottom.iocb = null;

	xmail_windows.status.position,
	     xmail_windows.menu.position,
	     xmail_windows.bottom.position = 0;

	xmail_windows.initial_position = 0;

/* Find out if the video system is already on. */

	if video_data_$terminal_iocb ^= null
	then video_was_on = "1"b;
	else video_was_on = "0"b;

/***** Now really start setting things up. *****/

/* Set up interactive message handling. */

          call xmail_im_mgr_$init;                          /* always init */

	if xmail_data.interactive_msgs then do;
	     messages_need_cleanup = "1"b;		/* for cleanup */
	     call xmail_im_mgr_$defer_messages;
	end;

/* Find out if xmail has ever been invoked by this user before. */

	call xmail_value_$get_with_default ("lifetime_first_invocation", (YES), lifetime_first_invocation, code);
	if code ^= 0
	then do;
	     call xmail_error_$no_print (code, NAME, "l", "^a", INT_ERR);
	     lifetime_first_invocation = YES;
	end;

/* Turn on the video system. */

	if ^video_was_on
	then do;
	     call video_utils_$turn_on_login_channel (code, reason);
	     if code ^= 0
	     then do;
		if code = error_table_$no_table
		then call com_err_ (error_table_$invalid_device, NAME, "This command cannot operate with your current terminal type.");
		else call com_err_ (code, NAME, "^a", reason);
		goto ERROR_EXIT;
	     end;
	end;

/* Set up needed windows. */

	call xmail_window_manager_$create_windows (code);
	if code = xmail_err_$insuff_room_for_xmail
	then do;
	     call com_err_ (code, NAME, "^/The minimum number of lines needed is ^d.", xmail_windows.min_lines_needed);
	     goto ERROR_EXIT;
	end;
	else if code ^= 0
	then goto COMPLAIN;
	video_needs_cleanup = "1"b;			/* for cleanup */

	call iox_$modes (iox_$user_io, "", old_modes, code);
	if code ^= 0
	then call com_err_ (code, NAME, "Unable to get bottom window modes.  ^a", INT_ERR);
	else do;
	     if index (old_modes, FOLD_MODE) > 0
	     then do;
		call iox_$modes (iox_$user_io, WRAP_MODE, old_modes, code);
		if code ^= 0
		then call com_err_ (code, NAME, "Unable to set wrap mode in bottom window.  ^a", INT_ERR);
	     end;
	end;

	call xmail_sw_$initialize ();

	on condition (program_interrupt) begin;
		call window_$clear_window (iox_$user_io, code);
		goto xmail_data.first_label;
	     end;

	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		call window_$clear_window (iox_$user_io, code);
		goto xmail_data.first_label;
	     end;

MAIN_MENU:

	if lifetime_first_invocation = YES
	then call xmail_Getting_Started_ ();
	else call xmail_Executive_Mail_;

	goto MAIN_MENU;

QUIT:
	if lifetime_first_invocation = YES
	then do;
	     call xmail_value_$set ("lifetime_first_invocation", (NO), "", code);
	     if code ^= 0
	     then call xmail_error_$no_print (code, NAME, "l", "^a", INT_ERR);
	end;
	call xmail_review_defers_ ("message", "defer", 30);
	call xmail_review_defers_ ("reply", "reply", 30);
	call CLEANUP ("0"b);			/* not cleanup condition */
	goto EXIT;

COMPLAIN:
	call com_err_ (code, NAME, "^a", INT_ERR);

ERROR_EXIT:
	call CLEANUP ("0"b);			/* not cleanup condition */

EXIT:
	return;

ssu_exit: entry;

/* This entry doesn't do anything but it is needed by the ssu standalone */
/* invocation. It would be used by ssu_$print_message or 
/* ssu_$abort_subsystem if it were ever called during the invocation.    */

	return;

/* INTERNAL PROCEDURES */

CLEANUP: proc (condition_signalled);

/* PARAMETERS */

	dcl     condition_signalled	 bit (1);
          dcl prompt                     char (46) init ("                    Press <RETURN> to continue") int static options (constant);
	dcl 1 auto_query_info          like query_info;
          dcl been_thru_this_before      bit (1) aligned;
	dcl line                       char (80) var;
          dcl iox_$user_output           ptr ext static;
          dcl command_query_             entry() options(variable);
	dcl ENABLE_ESCAPE             bit (2) aligned init ("11"b) int static options (constant);         

						/* input parameter */
						/* 1 = cleanup condition */
						/* 0 = no condition */
						/* BEGIN */

	if sci_ptr ^= null ()
	then call ssu_$destroy_invocation (sci_ptr);
	if xmail_data_ptr = null then return;
	if xmail_data.error_seg_in_pdir & ^condition_signalled then do;

	     call adjust_bit_count_ ((get_pdir_()),(ERROR_LOG_SEGMENT), "0"b, bit_count, code);
	     if code = 0 & bit_count > 0 then do;
		call ioa_ ("^/               Xmail is closing down.");
		call ioa_ ("^/          An xmail error log was created in your process");
		call ioa_ ("     directory.  It will only exist for the duration of your");
		call ioa_ ("     process.  If you wish to save the error_messages that were");
		call ioa_ ("     written to the xmail.error segment, you should copy it from");
		call ioa_ ("     your process directory to another directory before");
		call ioa_ ("     you logout.");

	auto_query_info.version = query_info_version_6;
	auto_query_info.switches.yes_or_no_sw = "0"b;
	auto_query_info.switches.suppress_name_sw = "1"b;
	auto_query_info.switches.cp_escape_control = ENABLE_ESCAPE;
	auto_query_info.switches.suppress_spacing = "1"b;
	auto_query_info.switches.literal_sw = "0"b;
	auto_query_info.switches.prompt_after_explanation = "0"b;
	auto_query_info.switches.padding = "0"b;
	auto_query_info.status_code = 0;
	auto_query_info.query_code = 0;
	auto_query_info.question_iocbp = null ();	/* default: user_i/o */
	auto_query_info.answer_iocbp = null ();		/* default: user_input */
	auto_query_info.repeat_time = 0;		/* don't repeat */
	auto_query_info.explanation_ptr = null ();
	auto_query_info.explanation_len = 0;

	been_thru_this_before = "0"b;
	do while ("1"b);
	     call iox_$control (iox_$user_output, "reset_more", null, (0)); /* ignore code */

	     call command_query_ (addr (auto_query_info), line, "", "^[^/^]^a^2x", been_thru_this_before, prompt);
	     been_thru_this_before = "1"b;

	     if line = "" then goto CONTINUE;
	     end;
		end;
	     end;
CONTINUE: 
	if xmail_dir_opened then call xmail_dir_manager_$close_dir ();

	if video_needs_cleanup then do;

/* Reset fold mode if previously changed to wrap, do not ouput error 
   message if cleanup was signalled by condition                     */

	     if index (old_modes, FOLD_MODE) > 0
	     then do;
		call iox_$modes (iox_$user_io, FOLD_MODE, old_modes, code);
		if code ^= 0 & ^condition_signalled
		then call com_err_ (code, NAME, "Unable to reset fold mode in bottom window.  ^a", INT_ERR);
	     end;

/* pass parameter to flag condition */

	     call xmail_window_manager_$destroy_windows (condition_signalled);
	     if ^video_was_on then call video_utils_$turn_off_login_channel (0);
	end;

	if messages_need_cleanup & xmail_data.interactive_msgs then do;
	     if ^condition_signalled			/* only print if not condition */
	     then call xmail_im_mgr_$print_messages;
	     call xmail_im_mgr_$restore_original;         /* restore users method of handling messages when leaving */
	end;

	if xmail_data.function_key_data_ptr ^= null ()
	then free xmail_data.function_key_data_ptr -> function_key_data;
	     
	xmail_data_ptr = null;


     end CLEANUP;

     end xmail;




		    xmail_Consult_Files_.pl1        09/02/88  0759.6r w 09/02/88  0745.0      255069



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




/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-01-07,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-22 JG Backs: Modified SELECT_FILE proc, adding call to ioa_ to
     display a message to user that the file is being worked on.  If the file
     is large, opening will take some time and the user should know something
     is happening.
  2) change(86-01-07,Blair), approve(86-01-07,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     Modify SELECT_FILE to call a new entrypoint in xmail_select_files for
     the 'select new file' option to allow selecting other users' mailboxes.
  3) change(86-02-25,Blair), approve(86-02-25,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     Change call to xmail_select_msgs_ in OPT (6) so that this option can be
     used to set the seen switch for messages as well as select them. Now there
     is a ptr to a structure of seen_msgs, and a switch_on_off flag.
  4) change(87-01-19,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Set the bit xmail_data.msgs_as_mail to reflect whether or not we're
     processing interactive msgs.
  5) change(87-02-10,Blair), approve(87-02-10,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Test for whether or not we're processing a reply request when the
     redisplay menu condition has been signalled.  This prevents the screen
     being messed up after a reconnect. Error_list #114.
  6) change(87-09-16,Blair), approve(87-09-16,MECR0007),
     audit(87-09-16,LJAdams), install(87-09-16,MR12.1-1108):
     Initialize the xmail_data.reply_request bit to "0"b so that the Filed Mail
     menu will be built correctly (otherwise it gets supressed).
  7) change(87-10-05,Blair), approve(87-10-05,MCR7771),
     audit(87-11-02,LJAdams), install(87-11-02,MR12.2-1002):
     This installation resolves MECR0007.
                                                   END HISTORY COMMENTS */


xmail_Consult_Files_: proc ();

/* BEGIN DESCRIPTION

function:  This module produces th "Process Filed Mail" menu and allows
           selection of the options displayed.  Other xmail modules are
           called as a result of options selected.

history:       Author unknown

   83-06-21  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-09-22  DJ Schimke: Added calls to mail_system_$read_new_messages in the
   main option loop to keep the mailbox structure current. This is especially
   for the case where mail is filed into the current mailbox from the current
   mailbox. phx14804

   83-10-06  DJ Schimke: Changed both calls to xmail_file_msgs_ to calls to
   xmail_file_msgs_$current_msgs. The default file is now returned rather than
   kept as internal static in xmail_file_msgs_. These changes are a result of
   making xmail_file_msgs_ more robust.

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-02-07  DJ Schimke: Modified the code executed under xmail_err_$exit_now
   (PREV MENU key struck) to first revert the quit condition before calling
   done_with_file. This prevents a null pointer fault when the quit condition
   handler redirects execution back to the main loop (possibly after the 
   mailbox has been closed). phx16853

   84-04-10  DJ Schimke: Modified the code which checks the message count
   before opening a new mail file to allow opening of a mailbox without status
   permission to the mailbox. It now assumes there is at least 1 message so 
   that an attempt will be made to open the mailbox even if the message count
   cannot be determined (Normally we don't allow opening an empty mailbox.)
   The opening mode was also changed to ACCESSIBLE_MESSAGES rather than
   ALL_MESSAGES. This allows reading of any mailbox that you have at least
   "o" or "r" access to. 

   84-07-03  DJ Schimke: Modified to use a three-column menu format and to add 
   the "Write" option which calls xmail_write_msgs_. Replaced the "Message(s)" 
   in many menu options with "Messages" to reduce the width for three-column
   menu format.

   84-08-09  JG Backs: Added a call to xmail_list_msgs_$selected after the
   call to xmail_select_msgs_ when option (6) Select Messages is chosen, and
   after the call to xmail_select_msgs_$next when option (5) Next Message is
   chosen. This will automatically list the summary of newly selected messages.

   84-08-27  JG Backs: Created an internal procedure SELECT_FILE to replace the
   duplicate coding for selecting a new file within both PERFORM_OPTION and
   main proc.  This will insure a better message if there is incorrect access
   to a save mailbox.  phx18059.

   84-11-09  JG Backs: Modified to allow the updating and redisplay of the 
   current message line after messages are selected (option 6), but before
   they are listed.  This allows for the status line to be current if the 
   listing stops at a more prompt when there are many current messages.

   85-01-25 JG Backs: Added code to initialize file name at beginning of
   module.  The variable was tested in SELECT_FILE before being initialized.


END DESCRIPTION   
*/

/* AUTOMATIC */

          dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     default_file	 char (32) var;
	dcl     deletes_ptr		 ptr;
	dcl     dir		 char (168);
	dcl     display_needed	 bit (1) aligned;
	dcl     file		 char (32) varying;
	dcl     file_info		 char (256) var;
	dcl     multiple_msgs	 bit (1) aligned;
	dcl     new_dir		 char (168);
	dcl     new_file		 char (32) varying;
	dcl     old_no_of_entries	 fixed bin;
	dcl     ordinary_message_count, total_message_count fixed bin;
	dcl     pos_line		 char (256);
	dcl     position		 char (256) var;
          dcl     response               char (3) varying;	/* yes no or ask */          
	dcl     selecting_new_file	 bit (1) aligned;
	dcl     select_file_bad	 bit (1) aligned;
	dcl     status		 fixed bin (35);
          dcl     treat_msgs_as_mail     bit (1) aligned;
	dcl     unused_bit		 bit (1) aligned;
          dcl     unused_bit2            bit (1) aligned;
          dcl     yes_sw                 bit (1) aligned;
	dcl     another_mailbox	 bit (1) aligned;

	dcl     1 auto_open_options	 like open_options;
	dcl     1 auto_close_options	 like close_options;

/* BASED */

	dcl     1 deletes		 based (deletes_ptr),
		2 no_of_entries	 fixed bin,
		2 deletes_array	 (xn refer (no_of_entries)) char (25);

/* CONDITIONS */

	dcl     (cleanup, program_interrupt, xmail_redisplay_menu, quit) condition;

/* CONSTANTS */

	dcl     ALLOW_OLD		 bit (1) aligned init ("1"b) int static options (constant);
	dcl     ALLOW_SELECTION	 bit (1) aligned init ("1"b) int static options (constant);
	dcl     DONT_ALLOW_NEW	 bit (1) aligned init ("0"b) int static options (constant);
	dcl     EMPTY_FILE_MSG	 char (46) int static options (constant)
				 init ("There are no messages in the ""^a"" mail file.");
          dcl     MSGS_AS_MAIL           char (15) int static options (constant) init ("msgs_as_mail_yn");
	dcl     NAME		 init ("xmail_Consult_Files_") char (20) int static options (constant);
	dcl     N_COLUMNS		 fixed bin int static options (constant) init (3);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "Display",
				 "Reply",
				 "File Original",
				 "Discard Messages",
				 "Next Message",
				 "Select Messages",
				 "List Current Messages",
				 "List All Messages",
				 "Forward",
				 "Retrieve Messages",
				 "File Copy",
				 "Print",
				 "Write",
				 "Select New File"
				 ) dim (14) char (30) var;
	dcl     TITLE		 init ("Process Filed Mail") char (18)
				 int static options (constant);

/* BUILTINS */

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

/* ENTRIES */

	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);

	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     mail_system_$get_message_counts entry (char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     mail_system_$open_mailbox entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35));
	dcl     mail_system_$close_mailbox entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$read_new_messages entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
          dcl     xmail_error_$code_first entry() options(variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
          dcl     xmail_get_str_$yes_no  entry (char(*) var, bit(1) aligned);
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
          dcl     xmail_select_file_$foreign_mailboxes entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, 
		                     char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     xmail_select_msgs_$first entry (ptr, ptr, char (*));
	dcl     xmail_delete_dreply_	 entry (ptr);
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     xmail_sw_$update_position entry (char (*));
	dcl     xmail_undelete_msgs_   entry (ptr, ptr, char (*), char (*));
          dcl     xmail_value_$get_with_default entry (char(*), char(*) var, char(*) var, fixed bin(35));
		  
		  
/* EXTERNAL STATIC */

	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     iox_$user_output	 ptr ext static;
	dcl     mlsys_et_$no_more_messages fixed bin (35) ext static;
	dcl     mlsys_et_$no_r_permission fixed bin (35) ext static;
	dcl     xmail_err_$help_requested fixed bin (35) ext static;
	dcl     xmail_err_$exit_now	 fixed bin (35) ext static;

/* INTERNAL STATIC */

	dcl     menup		 int static ptr init (null);

/* INCLUDE FILES */

%include xmail_windows;
%page;
%include menu_dcls;
%page;
%include xmail_data;
%page;
%include window_dcls;
%page;
%include mlsys_open_options;
%page;
%include mlsys_close_options;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_message;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_responses;

/* BEGIN */
	on condition (xmail_redisplay_menu) begin;
		if menup ^= null then do;
		     if ^xmail_data.reply_request
			then call menu_$display (xmail_windows.menu.iocb, menup, code);
		     if code ^= 0
			then call xmail_error_$no_code (code, NAME, "l",
			"Unable to display menu. This is an internal programming error.");
		     end;
		end;
	     
	deletes_ptr = null ();
	call hcs_$make_seg ("", "seg_of_deletes2", "", 01010b, deletes_ptr, (0));
	no_of_entries, old_no_of_entries = 0;

	file = "";				/* initialize file name */
	mailbox_ptr = null;
	curr_msgsp = null;
	xmail_data.cleanup_signalled, xmail_data.reply_request = "0"b;

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

	selecting_new_file = "0"b;

	if menup = null
	then do;
	     call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menup, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, NAME, "q",
		     "Unable to get menu. This is an internal programming error.");
	end;

	call SELECT_FILE;
	if select_file_bad
	then go to EXIT;

	on condition (program_interrupt) go to START;
	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

START:	display_needed = "1"b;

	do while ("1"b);

	     if mailbox_ptr = null
	     then do;
		file = " ";
		file_info = " ";
		position = "Current message:  ";
		go to skipit;
	     end;

	     call ioa_$rsnnl ("Total messages: ^d", file_info, (0), mailbox.n_messages - mailbox.n_deleted_messages);
	     if curr_msgsp ^= null
	     then if curr_msgs.count > 1
		then multiple_msgs = "1"b;
		else multiple_msgs = "0"b;

	     call ioa_$rsnnl ("Current message^[^ss^;^[s^]^]: ^a", position, (0), curr_msgsp = null, multiple_msgs, pos_line);

skipit:	     call xmail_get_choice_ (menup,
		"File: " || file,
		(file_info),
		(position),
		xmail_data.normal_usage,
		display_needed,
		"",
		choice,
		code);
	     display_needed = "0"b;
	     if code = 0
	     then do;
		call PERFORM_OPTION (choice, display_needed);
		call mail_system_$read_new_messages (mailbox_ptr, (0), (0), (0), status);
		if status ^= 0 & status ^= mlsys_et_$no_more_messages
		then call xmail_error_$no_code (status, NAME, "q", "Unable to read mail file. This is an internal programming error.");
	     end;
	     else if code = xmail_err_$help_requested
	     then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now
	     then do;				/* PREV MENU */
		revert quit;			/* close null pointer window */
		call done_with_file ();
		go to EXIT;
	     end;
	     else do;
		call window_$bell (iox_$user_output, code);
		if code ^= 0
		then call xmail_error_$no_print (code, NAME, "l", "Cannot ring terminal bell. This is an internal programming error.");
	     end;
	end;

EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* PARAMETERS */

	dcl     opt		 fixed bin;
	dcl     redisplay		 bit (1) aligned;

/* AUTOMATIC */

	dcl     deleted_msg_string	 char (25);
	dcl     message_num		 fixed bin;
	dcl     idx		 fixed bin;
	dcl     idx1		 fixed bin;
	dcl     dreply_msg_ptr	 ptr;
	dcl     counter		 fixed bin;
          dcl     seen_msgsp             ptr;
          dcl     switch_on_off          bit (2) aligned;
          dcl     switch                 bit (1) aligned;
	      
/* CONSTANTS */

	dcl     mailbox_empty_msg	 char (19) static options (constant) init
				 ("Mail file is empty.");
          dcl     SWITCH_ON              bit (2) aligned init ("10"b) int static options (constant);
	      
/* ENTRIES */

	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     xmail_delete_msgs_	 entry (ptr, ptr, char (*), char (*));
	dcl     xmail_display_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_dprint_msgs_	 entry (ptr, ptr);
	dcl     xmail_file_msgs_$current_msgs entry (ptr, ptr, char (32) var, bit (1) aligned);
	dcl     xmail_forward_msg_	 entry (ptr, ptr);
	dcl     xmail_list_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_list_msgs_$selected entry (ptr, ptr, ptr);
          dcl     xmail_list_msgs_$set_seen_switch entry (ptr, ptr, bit (1) aligned);
	dcl     xmail_reply_msg_	 entry (ptr, ptr);
	dcl     xmail_select_msgs_	 entry (ptr, ptr, ptr, bit (2) aligned, char (*));
	dcl     xmail_select_msgs_$next entry (ptr, ptr, char (*));
	dcl     xmail_write_msgs_	 entry (ptr, ptr);

/* BEGIN PERFORM_OPTION */

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0
	then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");

	go to OPT (opt);


OPT (1):						/* Display Option */
	if curr_msgsp ^= null ()
	then call xmail_display_msgs_ (mailbox_ptr, curr_msgsp, iox_$user_output);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (2):						/* Reply option */
	if curr_msgsp ^= null ()
	then call xmail_reply_msg_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (3):						/* File Original Option */
	if curr_msgsp ^= null () then do;
	     call xmail_file_msgs_$current_msgs (mailbox_ptr, curr_msgsp, default_file, ALLOW_SELECTION);
	     call mail_system_$read_new_messages (mailbox_ptr, (0), (0), (0), status);
	     if status ^= 0 & status ^= mlsys_et_$no_more_messages
	     then call xmail_error_$no_code (status, NAME, "q", "Unable to read mail file. This is an internal programming error.");
	     if default_file ^= ""
	     then call delete_msgs;
	end;
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (4):						/* Delete Option */
	if curr_msgsp ^= null ()
	then call delete_msgs;
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (5):						/* Next Message Option */
	if curr_msgsp ^= null ()
	then do;
	     call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	     call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
	end;
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (6):						/* Select Messages Option */
	if curr_msgsp ^= null ()
	then do;
	     call xmail_select_msgs_ (mailbox_ptr, curr_msgsp, seen_msgsp, switch_on_off, pos_line);
	     call window_$clear_window (iox_$user_output, code);
	     if code ^= 0
	     then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");

/* update and redisplay the new message line before list */

	     if seen_msgsp ^= null
	     then do;
		     if switch_on_off = SWITCH_ON  then switch = "1"b;
		     else switch = "0"b;
		     call xmail_list_msgs_$set_seen_switch (mailbox_ptr, seen_msgsp, switch);
		     free seen_msgsp -> curr_msgs;
		     end;
	     else if curr_msgsp ^= null then do;
		if curr_msgs.count > 1
		then multiple_msgs = "1"b;
		else multiple_msgs = "0"b;
		call ioa_$rsnnl ("Current message^[^ss^;^[s^]^]: ^a", position, (0), curr_msgsp = null, multiple_msgs, pos_line);
		call xmail_sw_$update_position ((position));
		call xmail_sw_$redisplay ();
		call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
		end;
	end;
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (7):						/* Display Summary of Current Messages Option */

	if curr_msgsp ^= null ()
	then call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (8):						/* Display Summary of Messages Option */
	if curr_msgsp ^= null ()
	then call xmail_list_msgs_ (mailbox_ptr, curr_msgsp, iox_$user_output);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (9):						/* Forward  option */
	if curr_msgsp ^= null ()
	then call xmail_forward_msg_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (10):						/* Undelete Messages Option */
	if mailbox_ptr ^= null ()
	then do;
	     call xmail_undelete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, "");
	     if curr_msgsp = null ()
	     then go to PERFORM_EXIT;

	     do idx = 1 to curr_msgs.count;
		message_num = curr_msgs.numbers (idx);
		if mailbox.messages (message_num).message_ptr = null
		then do;
		     call mail_system_$read_message (mailbox_ptr, message_num, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
		end;
		dreply_msg_ptr = mailbox.messages (message_num).message_ptr;
		deleted_msg_string = unique_chars_ ((dreply_msg_ptr -> message.header.message_id)) || ".reply";
		do idx1 = 1 to no_of_entries;
		     if deletes_array (idx1) = deleted_msg_string
		     then deletes_array (idx1) = "";
		end;				/* end do */
	     end;					/*end do */
	end;

	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (11):						/* File Copy Option */
	if curr_msgsp ^= null ()
	then call xmail_file_msgs_$current_msgs (mailbox_ptr, curr_msgsp, default_file, ALLOW_SELECTION);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (12):						/* Print Option */
	if curr_msgsp ^= null ()
	then call xmail_dprint_msgs_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (13):						/* Write Option */
	if curr_msgsp ^= null ()
	then call xmail_write_msgs_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (mailbox_empty_msg);
	go to PERFORM_EXIT;

OPT (14):						/* Select New File Option */
	selecting_new_file = "1"b;
	xmail_data.foreign_mailbox = "1"b;
	
	call SELECT_FILE;
	xmail_data.foreign_mailbox = "0"b;
	if select_file_bad
	then go to PERFORM_EXIT;
	else go to START;


delete_msgs: proc;					/* Internal to PERFORM_OPTION proc */

	no_of_entries = old_no_of_entries + curr_msgs.count;
	call hcs_$set_bc_seg (deletes_ptr, no_of_entries * 225 + 36, code);
	counter = 0;
	do idx = (old_no_of_entries + 1) to no_of_entries;
	     counter = counter + 1;
	     message_num = curr_msgs.numbers (counter);
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		call mail_system_$read_message (mailbox_ptr, message_num, code);
		if code ^= 0
		then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
	     end;
	     dreply_msg_ptr = mailbox.messages (message_num).message_ptr;
	     deletes_array (idx) = unique_chars_ ((dreply_msg_ptr -> message.header.message_id)) || ".reply";
	     call hcs_$status_minf ((mail_dir), (deletes_array (idx)), (0), (0), (0), code);
	     if code = 0
	     then call ioa_ ("^/   The deferred reply for message no.^d was discarded.^/   To retrieve it, select the ""Retrieve Messages"" option.^/", message_num);
	end;

	old_no_of_entries = no_of_entries;
	call xmail_delete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, (file));
	return;
     end delete_msgs;

PERFORM_EXIT:
	if mailbox_ptr = null			/* test for null file */
	then go to START;
	return;

     end PERFORM_OPTION;

SELECT_FILE: proc;

/* function: a new internal procedure to select a new mail file to process.
             Called from both main and PERFORM_OPTION procedures.  The
             variable, select_file_bad, is set upon entry and will only be 
             cleared if everything is OK.	   
*/
	   dcl file_name  char (32);

/* BEGIN SELECT_FILE */

	select_file_bad = "1"b;

	if xmail_data.foreign_mailbox then do;
	     call xmail_select_file_$foreign_mailboxes ("mail file", "sv.mbx", "", ALLOW_OLD, DONT_ALLOW_NEW, new_dir, new_file, "Enter name of mail file you wish to process (or ?? for list)",another_mailbox, unused_bit, code);
	     if code ^= 0 | file = new_file 
		then goto SELECT_EXIT;
	     end;
         else do;
	     call xmail_select_file_$caller_msg ("mail file", "sv.mbx", "", ALLOW_OLD, DONT_ALLOW_NEW, new_dir, new_file, "Enter name of mail file you wish to process (or ?? for list)", unused_bit, unused_bit2, code);
	if code ^= 0 | file = new_file
	then go to SELECT_EXIT;
		                                        /* msg to user */
	call ioa_ ("The ""^a"" file has been selected...", new_file); 

/* Allow no_s_permission for reading of mailboxes other than user's. */

	call mail_system_$get_message_counts (new_dir, new_file || ".sv", "1"b, total_message_count, ordinary_message_count, (0), code);
	if code = mlsys_et_$no_r_permission
	then call xmail_error_$no_code (code, NAME, "i", " You do not have access to read the ""^a"" mail file.", new_file);
	else if code = 0 & total_message_count = 0
	then do;
	     call ioa_ (EMPTY_FILE_MSG, new_file);
	     go to SELECT_EXIT;
	     end;
	end;

/* Option "Select New File" */

	if selecting_new_file
	then do;
	     call done_with_file ();
	     selecting_new_file = "0"b;
	end;

/* Set up to open mailbox */

	default_file = "";
	dir = new_dir;
	file = new_file;

/* Determine if we want all msgs or just ordinary ones */
	call xmail_value_$get_with_default (MSGS_AS_MAIL, (NO), response, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, "q",
		"^/Unable to get a value for ""^a"" in the xmail value segment.", MSGS_AS_MAIL);

	treat_msgs_as_mail = "0"b;
	if response = YES
          then do;
	     treat_msgs_as_mail = "1"b;
	     xmail_data.msgs_as_mail = "1"b;
	     end;
	else if response = ASK
	then do;
		call xmail_get_str_$yes_no ("Do you wish to treat interactive msgs as mail? ", yes_sw);
		if yes_sw then do;
		     treat_msgs_as_mail = "1"b;
		     xmail_data.msgs_as_mail = "1"b;
		     end;
	     end;
	else xmail_data.msgs_as_mail = "0"b;
	
/* Open the mailbox and set the first current message to one */

	auto_open_options.version = OPEN_OPTIONS_VERSION_2;
	if treat_msgs_as_mail then
	auto_open_options.message_selection_mode = ALL_MESSAGES;
	else auto_open_options.message_selection_mode = ORDINARY_MESSAGES;
/*	if xmail_data.foreign_mailbox
	     then auto_open_options.message_selection_mode = OWN_MESSAGES;
	else
	     auto_open_options.message_selection_mode = ORDINARY_MESSAGES; */
	auto_open_options.sender_selection_mode = ACCESSIBLE_MESSAGES;
	auto_open_options.message_reading_level = READ_KEYS;

	if ^another_mailbox
	     then file_name = rtrim(file) || ".sv";
	else
	      file_name = file;
	
	call mail_system_$open_mailbox (dir, rtrim(file_name), addr (auto_open_options), MAILBOX_VERSION_2, mailbox_ptr, code);
	if code = error_table_$moderr
	then call xmail_error_$no_code (code, NAME, "i", " You do not have access to read the ""^a"" mail file.", file);
	else if code ^= 0
	then call xmail_error_$no_code (code, NAME, "q", "Unable to open mail file, ""^a"".", file);

		                                        /* clear msg */
	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");

/* test for no accessible messages in mail file */

	if mailbox.n_messages = 0
	then do;
	     call done_with_file;
	     call ioa_ (EMPTY_FILE_MSG, new_file);
	     go to SELECT_EXIT;
	end;

	call xmail_select_msgs_$first (mailbox_ptr, curr_msgsp, pos_line);
	if curr_msgsp = null
	then do;
	     call done_with_file ();
	     go to SELECT_EXIT;
	end;


/* Clear to indicate file OK */

	select_file_bad = "0"b;

SELECT_EXIT:
	return;

     end SELECT_FILE;

EXPLAIN_OPTION: proc (opt);

/* PARAMETERS */

	dcl     opt		 fixed bin;

/* ENTRIES */

	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));

/* BEGIN EXPLAIN_OPTION */

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0
	then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");
	call xmail_display_help_ (NAME || ".gi.info",
	     translate (OPTION_NAMES (opt), "_", " "), code);
	if code ^= 0
	then call xmail_error_$no_print (code, NAME, "l", "Unable to display help. This is an internal programming error.");

     end EXPLAIN_OPTION;

done_with_file: proc ();

	if mailbox_ptr ^= null
	then do;
	     if xmail_data.cleanup_signalled 
		then call xmail_undelete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, "");
	     xmail_data.cleanup_signalled = "0"b;
	     auto_close_options.version = CLOSE_OPTIONS_VERSION_2;
	     auto_close_options.flags.perform_deletions = "1"b;
	     auto_close_options.flags.report_deletion_errors = "0"b;
	     auto_close_options.flags.mbz = "0"b;
	     call mail_system_$close_mailbox (mailbox_ptr, addr (auto_close_options), code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, "l", "Unable to close user mailbox. This is an internal programming error.");
	end;

          xmail_data.foreign_mailbox = "0"b;
	if curr_msgsp ^= null ()
	then do;
	     free curr_msgs;
	     curr_msgsp = null ();
	end;
	if (deletes_ptr ^= null () & no_of_entries ^= 0) then call xmail_delete_dreply_ (deletes_ptr);
	old_no_of_entries = 0;

     end done_with_file;


     end xmail_Consult_Files_;





		    xmail_Executive_Mail_.pl1       09/02/88  0759.6r w 09/02/88  0746.6       94374



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



/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-22  JG Backs: Deleted the parameter from xmail_Mail_File_Maint_
     references.  This parameter was not needed and was being passed a null
     string.
  2) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Set the flag to allow users to read their own mail in other people's
     mailboxes just before choosing the option to select other files.
  3) change(87-01-19,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Determine whether we should look at all messages in the mailbox or just
     ordinary ones before checking to see if there are any messages in the box.
                                                   END HISTORY COMMENTS */


xmail_Executive_Mail_: proc;

/* BEGIN DESCRIPTION

history:
   Author unknown.

   81-07-20  Paul Kyzivat: Modified to add Review Defaults.

   81-07-21  Paul Kyzivat: Modified to add option help.

   83-06-27  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-10-06  DJ Schimke: Replaced call to xmail_get_line_ and associated code
   which asked a yes_no question with a call to xmail_get_str_$yes_no.

   84-01-04  DJ Schimke: Corrected the order of the arguments to ioa_$rsnnl
   reported in phx16645. Replaced the (0) in the ioa_$rsnnl calls with a new
   variable "unused_return_length".

   84-07-02  DJ Schimke: Removed call to clear the user_i/o window when setting
   up. It is not necessary (all the winodws are cleared individually) and was
   causing the status window to not be displayed properly. This is part of the
   change for xmail error #92.

   84-07-03  DJ Schimke: Modified the call to xmail_create_menu_ to add the
   N_COLUMNS parameter.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     display_needed	 bit (1) aligned;
	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     yes_sw		 bit (1) aligned;
	dcl     (ordinary_message_count, total_message_count, message_count) fixed bin;
	dcl     prompt_string	 char (100) var;
	dcl     response		 char (3) varying;	/* yes no or ask */          
	dcl     unused_return_length	 fixed bin (21);
          dcl     treat_msgs_as_mail     bit (1) aligned;
		   
/* CONSTANTS */

          dcl     MSGS_AS_MAIL           char (15) int static options (constant) init ("msgs_as_mail_yn");
	dcl     NAME		 init ("xmail_Executive_Mail_") char (21) int static options (constant);
	dcl     N_COLUMNS		 fixed bin int static options (constant) init (2);
	dcl     OPTION_NAMES	 int static options (constant) init (  
				 "Process Incoming Mail",
				 "Send Mail",
				 "Process Filed Mail",
				 "Mailing Lists",
				 "Review Mail Files",
				 "Personalize Exec Mail",
				 "Getting Started"
				 ) dim (7) char (24) varying;

/* BUILTINS */

	dcl     (null, sum, translate) builtin;

/* CONDITIONS */

	dcl     (cleanup, program_interrupt, quit, xmail_leave_menu, xmail_redisplay_menu) condition;

/* ENTRIES */

	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     mail_system_$get_message_counts entry (char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_display_menu_	 entry (ptr, fixed bin, fixed bin (35));
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
          dcl     xmail_value_$get_with_default entry (char(*), char(*) var, char(*) var, fixed bin(35));
	dcl     xmail_error_$code_first entry () options (variable);
		   

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr external static;
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);

/* INTERNAL STATIC */

	dcl     menu		 int static ptr init (null);

/* INCLUDE FILES */

%include star_structures;
%page;
%include menu_dcls;
%page;
%include xmail_data;
%page;
%include window_dcls;
%page;
%include xmail_windows;
%page;
%include xmail_responses;

/* START */

	star_names_ptr = null ();
	star_entry_ptr = null ();
	on condition (cleanup) call CLEAN_UP;

	on condition (xmail_leave_menu) ;

	on condition (xmail_redisplay_menu) begin;
		if menu ^= null
		then call menu_$display (xmail_windows.menu.iocb, menu, (0)); /* ignore error */
	     end;

	if menu ^= null then call xmail_display_menu_ (menu, 1, code);

	else call GET_MENU ();
	on condition (program_interrupt) go to START;
	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

START:	display_needed = "1"b;
	do while ("1"b);
	     call xmail_get_choice_ (menu, "", "", "", xmail_data.normal_usage, display_needed, "", choice, code);
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now then go to EXIT;
	     else call window_$bell (iox_$user_output, (0)); /* ignore error */
	end;

EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

	dcl     what_next		 char (9);
	dcl     opt		 fixed bin;
	dcl     redisplay		 bit (1) aligned;

	dcl     xmail_Process_Mail_	 entry (char (9), bit (1) aligned);
	dcl     xmail_Send_Mail_	 entry (char (9));
	dcl     xmail_Consult_Files_	 entry ();
	dcl     xmail_Review_Defaults_ entry ();
	dcl     xmail_Review_Mlist_	 entry ();
	dcl     xmail_Mail_File_Maint_ entry ();
	dcl     xmail_Getting_Started_ entry ();
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));


	call window_$clear_window (iox_$user_output, (0));/* ignore error */
	go to OPT (opt);

OPT (1):
	xmail_data.mail_in_incoming = "1"b;
/* Determine if we want all msgs or just ordinary ones */
	call xmail_value_$get_with_default (MSGS_AS_MAIL, (NO), response, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, "q",
		"^/Unable to get a value for ""^a"" in the xmail value segment.", MSGS_AS_MAIL);

	treat_msgs_as_mail = "0"b;
	if response = YES
          then do;
	     treat_msgs_as_mail = "1"b;
	     xmail_data.msgs_as_mail = "1"b;
	     end;
	else if response = ASK
	then do;
		call xmail_get_str_$yes_no ("Do you wish to treat interactive msgs as mail? ", yes_sw);
		if yes_sw then do;
		     treat_msgs_as_mail = "1"b;
		     xmail_data.msgs_as_mail = "1"b;
		     end;
	     end;
	else xmail_data.msgs_as_mail = "0"b;

/* Open the mailbox and set the first current message to one */

	call mail_system_$get_message_counts ((xmail_data.mail_dir), "incoming", "1"b, total_message_count, ordinary_message_count, (0), code);
	if treat_msgs_as_mail then message_count = total_message_count;
	else message_count = ordinary_message_count;
	if message_count = 0
	then do;
	     xmail_data.mail_in_incoming = "0"b;
	     call iox_$control (iox_$user_output, "reset_more", null, (0)); /* ignore error */
	     call ioa_ ("There are no messages in your ""incoming"" mailbox.");
	     call hcs_$star_ ((xmail_data.mail_dir), "*.mbx", star_ALL_ENTRIES, null (), star_entry_count, (null ()), (null ()), code);
	     if star_entry_count <= 1 then go to OPT_EXIT;
	     call ioa_$rsnnl ("Still wish to go to ""Process Incoming Mail""?  (y,n) ", prompt_string, unused_return_length);
	     call xmail_get_str_$yes_no (prompt_string, yes_sw);
	     if yes_sw then call window_$clear_window (iox_$user_output, code);
	     else go to OPT_EXIT;
	end;
	what_next = "";
	redisplay = "1"b;
	call xmail_Process_Mail_ (what_next, treat_msgs_as_mail);
	if what_next = "send_mail" then go to OPT (2);
	go to OPT_EXIT;

OPT (2):	what_next = "";
	redisplay = "1"b;
	call xmail_Send_Mail_ (what_next);
	if what_next = "proc_mail" then go to OPT (1);
	go to OPT_EXIT;

OPT (3):	redisplay = "1"b;
	xmail_data.foreign_mailbox = "1"b;
	call xmail_Consult_Files_ ();
	xmail_data.foreign_mailbox = "0"b;
	go to OPT_EXIT;

OPT (4):	redisplay = "1"b;
	call xmail_Review_Mlist_ ();
	go to OPT_EXIT;

OPT (5):	redisplay = "1"b;
	call xmail_Mail_File_Maint_ ();
	go to OPT_EXIT;

OPT (6):	redisplay = "1"b;
	call xmail_Review_Defaults_;
	go to OPT_EXIT;

OPT (7):	redisplay = "1"b;
	call xmail_Getting_Started_ ();
	go to OPT_EXIT;

OPT_EXIT: return;
     end PERFORM_OPTION;


EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin;

	call window_$clear_window (iox_$user_output, (0));/* ignore error */
	call xmail_display_help_ (NAME || ".gi.info",
	     translate (OPTION_NAMES (opt), "_", " "),
	     (0));				/* ignore error */
	return;

     end EXPLAIN_OPTION;

GET_MENU: proc;

	dcl     title		 char (xmail_windows.menu.width) var;

	dcl     status		 fixed bin (35);

	dcl     xmail_error_$no_code	 entry options (variable),
	        xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));

	call ioa_$rsnnl ("Executive Mail (Version ^a)", title, unused_return_length, xmail_version);

	call xmail_create_menu_ ((title), OPTION_NAMES, N_COLUMNS, menu, status);
	if status ^= 0
	then call xmail_error_$no_code (status, NAME, "q",
		"A programming error has been detected which prevents " ||
		"the use of the ^a menu.", title);	/* never returns */
	call xmail_display_menu_ (menu, 1, code);

	return;
     end GET_MENU;

CLEAN_UP: proc;
	if star_names_ptr ^= null () then free star_names;/* order is important */
	if star_entry_ptr ^= null () then free star_entries;
     end CLEAN_UP;

    end xmail_Executive_Mail_;





		    xmail_Getting_Started_.pl1      05/28/86  1058.5r w 05/28/86  1027.3       58059



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

/* Author unknown

   84-07-03  DJ Schimke: Modified the call to xmail_create_menu_ to add the
   N_COLUMNS parameter.
*/

xmail_Getting_Started_: proc ();

/* Automatic */

	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     display_needed	 bit (1) aligned;
	dcl     initial_menu_help	 char (32) var;
	dcl     saw_lifetime_init_info char (3) var init ("");

/* Entries */

	dcl     menu_$display	 entry (ptr, ptr, fixed bin (35));
	dcl     window_$bell	 entry (ptr, fixed bin (35));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_Executive_Mail_	 entry options (variable);
	dcl     xmail_get_choice_$dm	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35));
	dcl     xmail_value_$set	 entry (char (*), char (*) var, char (*) var, fixed bin (35));

/* Builtin */

	dcl     (null, translate)	 builtin;

/* Condition */

	dcl     (program_interrupt, xmail_leave_menu, xmail_redisplay_menu, quit) condition;

/* Constant */

	dcl     NAME		 char (22) init ("xmail_Getting_Started_") int static options (constant);
	dcl     N_COLUMNS		 fixed bin static options (constant) init (2);
	dcl     OPTION_NAMES	 (7) char (29) var int static options (constant)
				 init ("Getting to Know Your Terminal",
				 "How to Get Help",
				 "How to Get Out",
				 "Getting Around",
				 "How to Correct Typos",
				 "Personalizing Executive Mail",
				 "Go To Executive Mail Menu");

	dcl     BEGIN_USAGE		 char (59) init ("Press a number and the associated action will be performed.") int static options (constant);

/* External Static */

	dcl     iox_$user_output	 ptr ext static;

	dcl     (xmail_err_$exit_now,
	        xmail_err_$help_requested) fixed bin (35) ext static;

/* Internal Static */

	dcl     menup		 ptr init (null) int static;

	on condition (xmail_leave_menu) ;

	on condition (xmail_redisplay_menu) begin;
		if menup ^= null
		then call menu_$display (xmail_windows.menu.iocb, menup, (0));
	     end;

	if menup = null
	then call GET_MENU ();

	call xmail_value_$get_with_default ("saw_lifetime_init_info", "no", saw_lifetime_init_info, code);
	if code ^= 0
	then do;
	     call xmail_error_$no_code (code, NAME, "l", "Unable to get info from user value segment. This is an internal programming error.");
	     saw_lifetime_init_info = "no";
	end;

	if saw_lifetime_init_info = "yes"
	then initial_menu_help = "";
	else initial_menu_help = INITIAL_HELP;

	on condition (program_interrupt) go to START;
	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to clear user_io window. This is an internal programming error.");

START:

	display_needed = "1"b;

	do while ("1"b);
	     call xmail_get_choice_$dm (menup, "", "", "", BEGIN_USAGE, display_needed, (initial_menu_help), choice, code);
	     if saw_lifetime_init_info = "no"
	     then do;
		call xmail_value_$set ("saw_lifetime_init_info", "yes", "", code);
		if code ^= 0
		then call xmail_error_$no_code (code, NAME, "l", "Unable to set info in user value segment. This is an internal programming error.");
		initial_menu_help = "";
		saw_lifetime_init_info = "yes";
	     end;
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now then return;
	     else do;
		call window_$bell (iox_$user_output, code);
		if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to ring terminal bell. This is an internal programming error.");
	     end;
	end;
%page;
PERFORM_OPTION: proc (opt, redisplay);

	dcl     opt		 fixed bin;
	dcl     redisplay		 bit (1) aligned;
	dcl     code		 fixed bin (35);

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to clear user_io window. This is an internal programming error.");
	go to OPT (opt);

OPT (1): OPT (2): OPT (3): OPT (4): OPT (5): OPT (6):

	call xmail_display_help_ (GETTING_STARTED_HELP, translate (OPTION_NAMES (opt), "_", " "), code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to get help. This is an internal programming error.");

	return;

OPT (7):

	call xmail_Executive_Mail_ ();
	redisplay = "1"b;

	return;

     end PERFORM_OPTION;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin;
	dcl     code		 fixed bin (35);

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to clear user_io window. This is an internal programming error.");
	call xmail_display_help_ (NAME || ".gi.info", translate (OPTION_NAMES (opt), "_", " "), code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to get help. This is an internal programming error.");

     end EXPLAIN_OPTION;
%page;
GET_MENU: proc ();

	dcl     title		 char (15) init ("Getting Started");
	dcl     code		 fixed bin (35);
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));

	call xmail_create_menu_ (title, OPTION_NAMES, N_COLUMNS, menup, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, "q",
		"A programming error has been detected which prevents the use of the ^a menu.", title);

     end GET_MENU;


%page;
%include xmail_help_infos;
%page;
%include xmail_windows;

     end xmail_Getting_Started_;




		    xmail_Mail_File_Maint_.pl1      09/02/88  0759.6r w 09/02/88  0745.0      226251



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



/****^  HISTORY COMMENTS:
  1) change(86-02-03,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-01-18 JG Backs: Replaced call to SELECT_NEW_FILE at OPT (6) with a call
     to xmail_select_file_$caller_msg to eliminate opening the mailbox before
     renaming it.  Opening is not necessary and wastes time if a large file.
     Choosing this option will close the previous mailbox but only after the
     file to be renamed is accepted.
     85-04-22 JG Backs: Modified SELECT_NEW_FILE proc, adding call to ioa_ to
     display a message to user that the file is being worked on.  If the file
     is large, opening will take some time and the user should know something
     is happening.
     85-04-22 JG Backs: Deleted the P_default_file parameter from this module
     which was not being used.  Also modified xmail_Executive_Mail_.pl1 to
     call this module without a parameter, since it was only passing a null
     string and it is the only module to call this one.  Trimmed the suffix
     from star_names before listing the mail files and increasing the size
     of the space by one for each file.  This was a bug where there was no
     space between files names if a file of max size (25 char) was listed in
     the first column.
  2) change(86-02-03,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Free the star_entry structures and comment out an unnecessary call to
     select_msgs_$all so that there aren't a lot of things hanging around
     in the process_dir (with no way to get to them) which got allocated
     when various options were looped through in succession.  Error_list
     entry 116.
  3) change(87-01-19,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Add code to allow the user to discriminate between interactive and
     ordinary messages when listing them, but always select all and don't give
     him a choice if he is emptying, discarding or archiving his mailfile.
  4) change(87-01-21,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Check the width of the window to figure out how many columns are needed
     when we print a list of mail files.  Error_list #121.
                                                   END HISTORY COMMENTS */


xmail_Mail_File_Maint_: proc ;

/* BEGIN DESCRIPTION

history:
   Written by R. Ignagni Nov 1981 

   82-12-10 Schimke: Changed the code to use star_names (nindex(idx))
   rather than star_names (idx) so addnames on mail files don't cause errors
   when listing mail files. Also changed loop boundary from star_entry_count
   to sum(star_entries(*).nnames) so addnames can be used to delete the files.
   TRs: 13951, 13793, 13958, 12803

   83-06-27  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-10-12  DJ Schimke: Replaced call to xmail_archive_msgs_ by a call to the
   enhanced xmail_file_msgs_$current_msgs_. The only user-visible change is in
   the error messages which will say "file" rather than "archive". 

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-04-13  DJ Schimke: Deleted the call to mail_system_$get_message_count
   before opening a new mail file to allow opening of a mailbox without status
   permission to the mailbox. The message count obtained here wasn't even used.
   The opening mode was also changed to ACCESSIBLE_MESSAGES rather than
   ALL_MESSAGES. This allows reading of any mailbox that you have at least
   "o" or "r" access to. 

   84-07-03  DJ Schimke: Modified the call to xmail_create_menu_ to add the
   N_COLUMNS parameter for three-column menu format. 

   84-08-29  JG Backs: Modified SELECT_NEW_FILE proc to test for 0 messages
   in a new file immediately after opening mailbox.  If there are no messages,
   the file is closed and not displayed.  This prevents a fatal error if the
   user tries to retrieve deleted messages from someone elses mailbox when
   there are no accessible messages.


END DESCRIPTION   
*/

/* CONSTANTS */

	dcl     OPTION_NAMES	 int static options (constant) init (
				 "List Files",
				 "Create",
				 "Archive",
				 "Print",
				 "Empty",
				 "Rename",
				 "List Messages",
				 "Discard File",
				 "Retrieve Messages"
				 ) dim (9) char (20) var;

	dcl     ALLOW_NEW		 bit (1) aligned init ("1"b) int static options (constant);
	dcl     ALLOW_OLD		 bit (1) aligned init ("1"b) int static options (constant);
	dcl     DONT_ALLOW_NEW	 bit (1) aligned init ("0"b) int static options (constant);
	dcl     DONT_ALLOW_OLD	 bit (1) aligned init ("0"b) int static options (constant);
	dcl     FULL_MFILE_SUFFIX	 char (7) init (".sv.mbx") int static options (constant);
	dcl     MFILE_SUFFIX	 char (6) init ("sv.mbx") int static options (constant);
          dcl     MSGS_AS_MAIL           char (15) int static options (constant) init ("msgs_as_mail_yn");
	dcl     NAME		 char (22) init ("xmail_Mail_File_Maint_") int static options (constant);
	dcl     NL		 init ("
")				 char (1) int static options (constant);
	dcl     NO_FILE_MSG		 char (23) init ("You have no mail files.") int static options (constant);
	dcl     NO_SELECTION	 bit (1) aligned init ("0"b) int static options (constant);
	dcl     N_COLUMNS		 fixed bin int static options (constant) init (3);
	dcl     TITLE		 char (19) init (" Review Mail Files ") int static options (constant);

/* AUTOMATIC */

	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     default_file	 char (24) varying;
	dcl     dir		 char (168);
	dcl     display_needed	 bit (1) aligned;
	dcl     file		 char (32) varying;
	dcl     file_indicator	 char (32) var;
	dcl     file_info		 char (256) var;
	dcl     file_is_empty	 bit (1);
	dcl     last_file_used	 char (24) varying;
	dcl     last_opt		 fixed bin;
	dcl     multiple_msgs	 bit (1) aligned;
	dcl     new_dir		 char (168);
	dcl     new_file		 char (32) varying;
	dcl     pos_line		 char (256);
	dcl     position		 char (256) var;
          dcl     response               char (3)varying;
          dcl     treat_msgs_as_mail     bit (1) aligned;
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;
          dcl     yes_sw                 bit (1) aligned;
	dcl     1 auto_open_options	 like open_options;
	dcl     1 auto_close_options	 like close_options;

/* BUILTINS */

	dcl     (addr, before, char, divide, ltrim, null, rtrim, substr, sum, translate, trunc) builtin;

/* CONDITIONS */

	dcl     (cleanup, quit, program_interrupt, xmail_redisplay_menu) condition;

/* ENTRIES */

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     mail_system_$close_mailbox entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$open_mailbox entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35));
	dcl     mailbox_$chname_file	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
          dcl     xmail_error_$code_first entry() options(variable);
	dcl     xmail_error_$code_last entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
          dcl     xmail_get_str_$yes_no entry (char(*) var, bit(1) aligned);
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_select_msgs_$all entry (ptr, ptr, char (*));
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
          dcl     xmail_value_$get_with_default entry (char(*), char(*) var, char(*) var, fixed bin(35));
		    	   

/* EXTERNAL STATIC */

	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     iox_$user_output	 ptr external static;
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);
	dcl     xmail_err_$help_requested ext static fixed bin (35);

/* INTERNAL STATIC */

	dcl     menup		 int static ptr init (null);

/* INCLUDE FILES */

%include star_structures;
%page;
%include xmail_windows;
%page;
%include menu_dcls;
%page;
%include xmail_data;
%page;
%include window_dcls;
%page;
%include mlsys_open_options;
%page;
%include mlsys_close_options;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_message;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_responses;

/* BEGIN */

	on condition (xmail_redisplay_menu) begin;
		if menup ^= null
		then call menu_$display (xmail_windows.menu.iocb, menup, code);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, "l", "Unable to display menu. This is an internal programming error.");
	     end;

	menup = null ();
	last_opt = 0;
	default_file = "";
	mailbox_ptr = null;
	curr_msgsp = null;
	file_info = " ";
	position = " ";
	file = "";
	star_names_ptr = null ();
	star_entry_ptr = null ();

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

	if menup = null then do;
		call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menup, code);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, "q", "Unable to get menu. This is an internal programming error.");
	     end;

	on condition (program_interrupt) go to START;
	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

START:	display_needed = "1"b;

	do while ("1"b);

	     if star_names_ptr ^= null () then free star_names;/* order is important */
	     if star_entry_ptr ^= null () then free star_entries;
	     star_entry_ptr, star_names_ptr = null;
	     call hcs_$star_ ((xmail_data.mail_dir), "**" || FULL_MFILE_SUFFIX, star_ALL_ENTRIES, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, (0));

	     if mailbox_ptr = null ()
	     then do;
		     file_indicator = " ";
		     file_info = " ";
		     go to skipit;
		end;

	     call ioa_$rsnnl ("Total messages: ^d", file_info, (0), mailbox.n_messages - mailbox.n_deleted_messages);
	     if (mailbox.n_messages - mailbox.n_deleted_messages) > 0 then
		file_is_empty = "0"b;
	     else file_is_empty = "1"b;
	     if curr_msgsp ^= null     
	     then if curr_msgs.count > 1 then multiple_msgs = "1"b;
		else multiple_msgs = "0"b;
	     file_indicator = "File: " || file;
skipit:	     position = " ";
	     call xmail_get_choice_ (menup,
		(file_indicator),
		(file_info),
		(position),
		xmail_data.normal_usage,
		display_needed,
		"",
		choice,
		code);
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now
	     then go to EXIT;
	     else do;
		     call window_$bell (iox_$user_output, code);
		     if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot ring terminal bell. This is an internal programming error.");
		end;
	end;

EXIT:	call CLEAN_UP ();
	return;
%page;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* Auto */

	dcl     discarded		 bit (1) aligned;
	dcl     entry_is_link	 bit (1);
	dcl     i			 fixed bin;
	dcl     idx		 fixed bin;
	dcl     mbx_name		 char (32);
	dcl     msg_pointer		 ptr;
	dcl     opt		 fixed bin;
	dcl     redisplay		 bit (1) aligned;

/* Entries */

	dcl     mlsys_utils_$create_mailbox entry (char (*), char (*), fixed bin (35));
	dcl     xmail_delete_msgs_	 entry (ptr, ptr, char (*), char (*));
	dcl     xmail_discard_file_	 entry (ptr, ptr, char (*), bit (1) aligned);
	dcl     xmail_discard_file_$link entry (ptr, ptr, char (*), bit (1) aligned);
	dcl     xmail_dprint_msgs_	 entry (ptr, ptr);
	dcl     xmail_file_msgs_$current_msgs entry (ptr, ptr, char (32) var, bit (1) aligned);
	dcl     xmail_list_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_undelete_msgs_	 entry (ptr, ptr, char (*), char (*));



/* BEGIN PERFORM OPTION */

	call window_$clear_window (iox_$user_output, code);

	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");


	entry_is_link = "0"b;

	if opt = last_opt then last_file_used = "";
	else last_file_used = default_file;
	go to OPT (opt);

OPT (1):						/* List mail files option */

	if star_entry_count = 0
	then do;
		call ioa_ ("^a", NO_FILE_MSG);
		return;
	     end;

	call ioa_ ("You have ^d mail files:", star_entry_count);

	begin;
	     dcl	   mail_file_list	      char (star_entry_count * 27);
	     dcl	   char_count	      fixed bin;
	     dcl     no_columns             fixed bin;

	     mail_file_list = "";
	     char_count = 0;
/* How many columns will fit across our line width? */
	     no_columns = trunc(divide(xmail_windows.bottom.extent.width,26,2));
	     	     
	     do i = 1 to star_entry_count;                /* strip off suffix */
		star_names (star_entries.nindex (i)) = rtrim (before (star_names (star_entries.nindex (i)), FULL_MFILE_SUFFIX));
	     end;

	     do i = 1 by no_columns to star_entry_count;          /* put a newline char in front of each set of 3 files */

		star_names (star_entries.nindex (i)) = NL || substr (star_names (star_entries.nindex (i)), 1, 31);
	     end;

	     do i = 1 to star_entry_count;

		mail_file_list = substr (mail_file_list, 1, char_count) || (star_names (star_entries.nindex (i)));

		char_count = char_count + 27;
	     end;					/* end of do loop */
	     call ioa_ ("^a", mail_file_list);
	end;					/* end of begin block */
	return;



OPT (2):						/* Create mail file option */
	call xmail_select_file_$caller_msg ("mail file", MFILE_SUFFIX, "", DONT_ALLOW_OLD, ALLOW_NEW, new_dir, new_file, "Enter name of mail file you wish to create", unused_bit, unused_bit2, code);
	if code ^= 0
	then do;
		call ioa_ ("Unable to create mail file. This is an internal programming error.");
		return;
	     end;
	mbx_name = rtrim (new_file) || FULL_MFILE_SUFFIX;
	call mlsys_utils_$create_mailbox (new_dir, mbx_name, code);
	if code = 0
	then call ioa_ ("Mail file ""^a"" created.", new_file);
	else call ioa_ ("Unable to create mail file ""^a"".^/This is an internal programming error.", new_file);
	return;

OPT (3):						/*  Archive file option */

	if star_entry_count = 0
	then do;
		call ioa_ (NO_FILE_MSG);
		return;
	     end;
	if default_file = "xmail_archive" | file_is_empty then call SELECT_NEW_FILE ("archive", "");
	else call SELECT_NEW_FILE ("archive", (last_file_used));
	last_opt = opt;
	if file = "xmail_archive"
	then do;
		call ioa_ ("Sorry, but you cannot archive your archive file.");
		return;
	     end;

	if file_is_empty
	then do;
		call ioa_ ("Mail file ""^a"" is empty.", file);
		return;
	     end;
	call xmail_file_msgs_$current_msgs (mailbox_ptr, curr_msgsp, "xmail_archive", NO_SELECTION);
	call xmail_delete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, (file));
	file_is_empty = "1"b;
	return;

OPT (4):						/* Print all messages option */

	if star_entry_count = 0
	then do;
		call ioa_ (NO_FILE_MSG);
		return;
	     end;

	if file_is_empty then last_file_used = "";
	call SELECT_NEW_FILE ("print", (last_file_used));
	last_opt = opt;
	if file_is_empty
	then do;
		call ioa_ ("Mail file ""^a"" is empty.", file);
		return;
	     end;
	call xmail_dprint_msgs_ (mailbox_ptr, curr_msgsp);
	return;


OPT (5):						/* Empty File Option */

	if star_entry_count = 0
	then do;
		call ioa_ (NO_FILE_MSG);
		return;
	     end;

	if file_is_empty then last_file_used = "";
	call SELECT_NEW_FILE ("empty", (last_file_used));
	last_opt = opt;
	if file_is_empty
	then do;
		call ioa_ ("Mail file ""^a"" is already empty.", file);
		return;
	     end;
	call xmail_select_msgs_$all (mailbox_ptr, curr_msgsp, pos_line);
	call xmail_delete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, (file));
	file_is_empty = "1"b;
	return;

OPT (6):						/* Rename Option */

	if default_file = "outgoing" then last_file_used = "";

	call xmail_select_file_$caller_msg ("mail file", "sv.mbx", (last_file_used), ALLOW_OLD, DONT_ALLOW_NEW, new_dir, new_file, "Enter name of file you wish to rename", unused_bit, unused_bit2, code);

	if new_file = "outgoing"
	then do;
		call ioa_ ("Sorry, but the ""^a"" mail file is required and cannot be renamed.", new_file);
		return;
	     end;

	call done_with_file ();			/* close prev mailbox */
						/* but do not open new one */
	dir = new_dir;
	file = new_file;
	default_file = file;

	call ioa_$nnl ("Renaming ""^a"": ", file);
	call xmail_select_file_$caller_msg ("mail file", "sv.mbx", "", DONT_ALLOW_OLD, ALLOW_NEW, new_dir, new_file, "New name", unused_bit, unused_bit2, code);
	if code ^= 0
	then do;
		call ioa_ ("Selection of new mail file name not successful.");
		return;
	     end;

	call mailbox_$chname_file (rtrim (new_dir), file || "." || MFILE_SUFFIX, file || "." || MFILE_SUFFIX, rtrim (new_file) || "." || MFILE_SUFFIX, code);
	if code ^= 0 then call xmail_error_$code_last (code, NAME, "q", "Renaming of mail file failed.");
	call ioa_ ("Mail file name changed from ""^a"" to ""^a"".", file, new_file);
	file = new_file;
	dir = new_dir;
	default_file = file;
	last_opt = opt;
	return;

OPT (7):						/* Display Summary of Messages Option */

	if star_entry_count = 0
	then do;
		call ioa_ (NO_FILE_MSG);
		return;
	     end;

	if file_is_empty then last_file_used = "";
	call SELECT_NEW_FILE ("list", (last_file_used));
	last_opt = opt;
	if file_is_empty
	then do;
		call ioa_ ("Mail file ""^a"" is empty.", file);
		return;
	     end;
	call xmail_list_msgs_ (mailbox_ptr, curr_msgsp, iox_$user_output);
	return;

OPT (8):						/* Discard mail file option */

	if star_entry_count = 0
	then do;
		call ioa_ (NO_FILE_MSG);
		return;
	     end;
	if default_file = "outgoing" then call SELECT_NEW_FILE ("discard", "");
	else call SELECT_NEW_FILE ("discard", (last_file_used));
	if file = "outgoing"
	then do;
		call ioa_ ("Sorry, but the ""^a"" mail file is required and cannot be discarded.", file);
		return;
	     end;
	last_opt = opt;
	msg_pointer = curr_msgsp;
	if file_is_empty then msg_pointer = null ();
/*	else call xmail_select_msgs_$all (mailbox_ptr, msg_pointer, pos_line);     this is redundant because selection is done above  */
	do idx = 1 to star_entry_count;
	     do i = star_entries (idx).nindex to star_entries (idx).nindex + star_entries (idx).nnames - 1;
		if rtrim (file) = before (star_names (i), FULL_MFILE_SUFFIX) then go to success;
	     end;
	end;
	call xmail_error_$no_code (code, NAME, "q", "Sorry, but an internal programming error has occurred.^/Mail file ""^a"" could not be discarded.", file);

success:
	if star_entries (idx).type = 0
	then call xmail_discard_file_$link (mailbox_ptr, msg_pointer, (file), discarded);
	else call xmail_discard_file_ (mailbox_ptr, msg_pointer, (file), discarded);
/*	curr_msgsp = null;    */

	if discarded = "0"b then return;
	mailbox_ptr = null ();
	file_info = "";
	default_file = "";
	file = "";
	if (star_entry_count - 1) < 1
	then call ioa_ ("You have no more mail files.");
	return;

OPT (9):						/* Retrieve option */

	if mailbox_ptr = null ()
	then do;
		call ioa_ ("Sorry, but no messages can be retrieved for one
or more reasons:
 1. You have not discarded any messages
 2. You have changed mail file since you last discarded messages
 3. You have discarded the mail file");
		return;
	     end;
	call xmail_undelete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, "all");
	return;


     end PERFORM_OPTION;
%page;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin;

	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");
	call xmail_display_help_ (NAME || ".gi.info",
	     translate (OPTION_NAMES (opt), "_", " "), code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to display help. This is an internal programming error.");

     end EXPLAIN_OPTION;

done_with_file: proc ();

	if mailbox_ptr ^= null
	then do;
		auto_close_options.version = CLOSE_OPTIONS_VERSION_2;
		auto_close_options.flags.perform_deletions = "1"b;
		auto_close_options.flags.report_deletion_errors = "0"b;
		auto_close_options.flags.mbz = "0"b;
		call mail_system_$close_mailbox (mailbox_ptr, addr (auto_close_options), code);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, "l", "Unable to close user mailbox. This is an internal programming error.");
	     end;

	if curr_msgsp ^= null then do;
	     free curr_msgs;
	     curr_msgsp = null;
	     end;
	return;

     end done_with_file;

SELECT_NEW_FILE: proc (P_text, P_default_file);

	dcl     P_text		 char (*) parameter;
	dcl     P_default_file	 char (*) parameter;
	dcl     user_message	 char (78) varying;

	dcl     xmail_sw_$update_file	 entry (char (*));
	dcl     xmail_sw_$update_file_info entry (char (*));
	dcl     xmail_sw_$redisplay	 entry ();

	user_message = "Enter name of file you wish to " || P_text || " ";

	call xmail_select_file_$caller_msg ("file", "sv.mbx", (P_default_file), ALLOW_OLD, DONT_ALLOW_NEW, new_dir, new_file, (user_message), unused_bit, unused_bit2, code);
	if code = 0 then do;
		                                        /* msg to user */
	          call ioa_ ("The ""^a"" file has been selected...", new_file); 
		call done_with_file ();
		dir = new_dir;
		file = new_file;

/* Determine if we want all msgs or just ordinary ones */
		call xmail_value_$get_with_default (MSGS_AS_MAIL, (NO), response, code);
		if code ^= 0 then call xmail_error_$code_first (code, NAME, "q",
		     "^/Unable to get a value for ""^a"" in the xmail value segment.", MSGS_AS_MAIL);

		treat_msgs_as_mail = "0"b;
		if response = YES | choice = 3 | choice = 5 | choice = 8
		     then do;
		     treat_msgs_as_mail = "1"b;
		     xmail_data.msgs_as_mail = "1"b;
		     end;
		else if response = ASK
		     then do;
			call xmail_get_str_$yes_no ("Do you wish to treat interactive msgs as mail? ", yes_sw);
			if yes_sw then do;
			     treat_msgs_as_mail = "1"b;
			     xmail_data.msgs_as_mail = "1"b;
			     end;
			end;
		     else xmail_data.msgs_as_mail = "0"b;
		     
/* Open the mailbox and set the first current message to one */

		auto_open_options.version = OPEN_OPTIONS_VERSION_2;
		if treat_msgs_as_mail  then
		auto_open_options.message_selection_mode = ALL_MESSAGES;
		else auto_open_options.message_selection_mode = ORDINARY_MESSAGES;
		auto_open_options.sender_selection_mode = ACCESSIBLE_MESSAGES;
		auto_open_options.message_reading_level = READ_KEYS;

		call mail_system_$open_mailbox (dir, file || ".sv", addr (auto_open_options), MAILBOX_VERSION_2, mailbox_ptr, code);
		if code = error_table_$moderr then call xmail_error_$no_code (code, NAME, "i", "You do not have access to the ""^a"" mail file.", new_file);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, "q", "Unable to open mail file. This is an internal programming error.");

		                                        /* clear msg */
	          call window_$clear_window (iox_$user_output, code);
	          if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");

		if mailbox.n_messages = 0
		then do;
			call done_with_file;
			file_is_empty = "1"b;
		     end;
		else do;
			call xmail_select_msgs_$all (mailbox_ptr, curr_msgsp, pos_line);

			call xmail_sw_$update_file ("File: " || (file));
			call xmail_sw_$update_file_info (rtrim ("Total messages: " || ltrim (char (mailbox.n_messages - mailbox.n_deleted_messages))));
			call xmail_sw_$redisplay ();
			if (mailbox.n_messages - mailbox.n_deleted_messages) > 0
			then file_is_empty = "0"b;
			else file_is_empty = "1"b;
			default_file = file;
		     end;
	     end;

SELECT_NEW_FILE_EXIT:
	return;

     end SELECT_NEW_FILE;

CLEAN_UP: proc ();
	call done_with_file;
	if star_names_ptr ^= null () then free star_names;/* order is important */
	if star_entry_ptr ^= null () then free star_entries;
	return;
     end CLEAN_UP;

    end xmail_Mail_File_Maint_;





		    xmail_Process_Mail_.pl1         09/02/88  0759.6r w 09/02/88  0745.0      242136



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




/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-01-07,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     Added the variable foreign_mailbox to be set on before calling
     xmail_Consult_Files_ in Option 14 so we can access mail in other
     users' mailboxes.
  2) change(86-02-25,Blair), approve(86-02-25,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     Change call to xmail_select_msgs_ in OPT (6) so that this option can be
     used to set the seen switch for messages as well as select them. Now there
     is a ptr to a structure of seen_msgs, and a switch_on_off flag.
  3) change(87-01-21,Blair), approve(87-02-05,MCR7618),
     audit(87-04-14,RBarstad), install(87-04-26,MR12.1-1025):
     Pass a new parameter to indicate whether or not we're processing msgs
     as mail and get the msgs in the mailbox based on the value.
  4) change(87-02-10,Blair), approve(87-02-10,MCR7618),
     audit(87-04-14,RBarstad), install(87-04-26,MR12.1-1025):
     Check to see if we're processing a reply request when we execute the
     redisplay_menu condition code and don't display the menu on a reply.
     This prevents the screen being messed up after a reconnect. Error_list
     #114.
                                                   END HISTORY COMMENTS */


/* Author unknown.

   83-06-27  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes. 

   83-09-22  DJ Schimke: Added calls to mail_system_$read_new_messages in 
   PERFORM_OPTION to inform user of new mail and update mailbox structure so
   any new messages are available to the user. phx14130 Created the internal 
   procedures: delete_msgs and NEW_MESSAGES. 

   83-10-04  DJ Schimke: Changed want_to_examine_more internal proc to call
   xmail_get_str_$yes_no rather than xmail_get_str_.

   83-10-10  DJ Schimke: Changed bothg calls to xmail_file_msgs_ to calls to
   xmail_file_msgs_$current_msgs. The default file is now returned rather than
   kept as internal static in xmail_file_msgs_. These changes are a result of
   making xmail_file_msgs_ more robust.

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-04-11  DJ Schimke: Changed the opening sender_selection_mode from 
   ALL_MESSAGES to ACCESSIBLE_MESSAGES so mailboxes with either "r" or "o" 
   access can be opened and read.

   84-07-03  DJ Schimke: Modified to use a three-column menu format and to add 
   the "Write" option which calls xmail_write_msgs_. Replaced the "Message(s)" 
   in many menu options with "Messages" to reduce the width for three-column
   menu format.

   84-08-10  JG Backs: Added a call to xmail_list_msgs_$selected after the
   call to xmail_select_msgs_ when option (6) Select Messages is chosen, and
   after the call to xmail_select_msgs_$next when option (5) Next Message is
   chosen.  This will automatically list the summary of current messages.

   84-11-09  JG Backs: Modified to allow the updating and redisplay of the 
   current message line after messages are selected (option 6), but before
   they are listed.  This allows for the status line to be current if the 
   listing stops at a more prompt when there are many current messages.

   84-12-07  JG Backs: Changed the call to xmail_select_msgs_$next in OPT (2)
   in PERFORM OPTION proc to only occur if NEW_MESSAGES is true and
   curr_msgsp is null.  This is the same as all the other OPT's.  It was
   testing for curr_msgsp ^= null and in the case of replying and saving to
   incoming, the current messages line was being incorrectly updated to the
   next message.  TR 18632.

*/

/* format: style1 */
xmail_Process_Mail_: proc (what_next, treat_msgs_as_mail);

/* Parameter */

          dcl     treat_msgs_as_mail     bit (1) aligned;
	dcl     what_next		 char (9);


/* Automatic */

	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     def_prompt		 char (8) var;
	dcl     default_file	 char (32) var;
	dcl     deletes_ptr		 ptr;
	dcl     dir		 char (168);
	dcl     file		 char (32) varying;
	dcl     file_info		 char (256) var;
	dcl     multiple_msgs	 bit (1) aligned;
	dcl     n_interactive_msgs	 fixed bin;
	dcl     n_new_msgs		 fixed bin;
	dcl     n_total_msgs	 fixed bin;
	dcl     n_ordinary_msgs	 fixed bin;
	dcl     old_no_of_entries	 fixed bin;
	dcl     pos_line		 char (256);
	dcl     position		 char (256) var;
	dcl     redisplay_menu	 bit (1) aligned;
	dcl     return_to_caller	 bit (1) aligned;
	dcl     status		 fixed bin (35);
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;

	dcl     1 auto_open_options	 like open_options;
	dcl     1 auto_close_options	 like close_options;
		 
/* Constant */

	dcl     ALLOW_OLD		 bit (1) aligned init ("1"b) int static options (constant);
	dcl     ALLOW_SELECTION	 bit (1) aligned init ("1"b) int static options (constant);
	dcl     DONT_ALLOW_NEW	 bit (1) aligned init ("0"b) int static options (constant);
	dcl     NAME		 init ("xmail_Process_Mail_") char (19) int static options (constant);
	dcl     N_COLUMNS		 fixed bin int static options (constant) init (3);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "Display",	
				 "Reply",
				 "File Original",
				 "Discard Messages",
				 "Next Message",
				 "Select Messages",
				 "List Current Messages",
				 "List All Messages",
				 "Forward",
				 "Retrieve Messages",
				 "File Copy",
				 "Print",
				 "Write",
				 "Process Filed Mail",
				 "Send Mail"
				 ) dim (15) char (30) var;
	dcl     INCLUDE_BY_TYPE	 bit (1) aligned int static options (constant) init ("1"b);

/* Based */

	dcl     1 deletes		 based (deletes_ptr),
		2 no_of_entries	 fixed bin,
		2 deletes_array	 (xn refer (no_of_entries)) char (25);

/* Internal Static */

	dcl     menup		 int static ptr init (null);

/* External Static */

	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     iox_$user_output	 ptr external static;
	dcl     mlsys_et_$no_more_messages fixed bin (35) ext static;
	dcl     mlsys_et_$no_o_permission fixed bin (35) ext static;
	dcl     mlsys_et_$no_r_permission fixed bin (35) ext static;
	dcl     mlsys_et_$no_s_permission fixed bin (35) ext static;
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$int_prog_err ext static fixed bin (35);

/* Entries */

	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     mail_system_$close_mailbox entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$open_mailbox entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35));
	dcl     mail_system_$read_new_messages entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     xmail_delete_dreply_	 entry (ptr);
	dcl     xmail_display_menu_	 entry (ptr, fixed bin, fixed bin (35));
	dcl     xmail_error_$code_last entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_select_msgs_$first entry (ptr, ptr, char (*));
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     xmail_sw_$update_position entry (char (*));
	dcl     xmail_undelete_msgs_	 entry (ptr, ptr, char (*), char (*));
		 

/* Condition */

	dcl     (cleanup, program_interrupt, xmail_leave_menu, xmail_redisplay_menu, quit) condition;

/* Builtin */

	dcl     (addr, null, rtrim, translate) builtin;

	on condition (xmail_redisplay_menu) begin;
		if menup ^= null then do;
		     if ^xmail_data.reply_request
			then call menu_$display (xmail_windows.menu.iocb, menup, code);
		     if code ^= 0
			then do;
			     call xmail_error_$no_code (code, NAME, "l", "Sorry, unable to display menu. This is an internal programming error.");
			     call timer_manager_$sleep (4, "11"b);
			     end;
			end;
	     end;
		
	default_file = "";
	mailbox_ptr = null;
	curr_msgsp = null;
	xmail_data.cleanup_signalled, xmail_data.reply_request = "0"b;

	on condition (xmail_leave_menu) begin;
		call query_if_more_msgs ();
	     end;

	deletes_ptr = null ();
	call hcs_$make_seg ("", "seg_of_deletes1", "", 01010b, deletes_ptr, (0));
	no_of_entries, old_no_of_entries = 0;

	on condition (cleanup) begin;
		call leave_menu ();
	     end;
	if xmail_data.mail_in_incoming then def_prompt = "incoming";
	else def_prompt = "";
	call xmail_select_file_$caller_msg ("mailbox", "mbx", (def_prompt), ALLOW_OLD, DONT_ALLOW_NEW, dir, file, "Enter name of mailbox you wish to process", unused_bit, unused_bit2, code);
	if code ^= 0 then call error_leave_menu ();

	if menup ^= null then call xmail_display_menu_ (menup, 2, code);
	else call GET_MENU ();

/* Open the mailbox and set the first current message to one */

	auto_open_options.version = OPEN_OPTIONS_VERSION_2;
	if treat_msgs_as_mail then
	auto_open_options.message_selection_mode = ALL_MESSAGES;
	else auto_open_options.message_selection_mode = ORDINARY_MESSAGES;
	auto_open_options.sender_selection_mode = ACCESSIBLE_MESSAGES;
	auto_open_options.message_reading_level = READ_KEYS;

	call mail_system_$open_mailbox (dir, (file), addr (auto_open_options), MAILBOX_VERSION_2, mailbox_ptr, code);
	if code = 0 then go to all_ok;
	if code = error_table_$moderr | code = mlsys_et_$no_o_permission | code = mlsys_et_$no_r_permission
	then do;
		call ioa_ ("Sorry, but you do not have permission to read the specified mailbox.");
		call error_leave_menu ();
	     end;
	else do;
		call xmail_error_$code_last (xmail_err_$int_prog_err, NAME, "l", "Sorry, unable to get contents of mailbox:  ^a", (file));
		call error_leave_menu ();
	     end;
all_ok:
	call xmail_select_msgs_$first (mailbox_ptr, curr_msgsp, pos_line);
	if curr_msgsp = null			/* error has occured and been diagnosed */
	then call error_leave_menu ();
	if mailbox.n_messages = 0
	then do;
		call ioa_ ("There are no messages in the ""^a"" mailbox.", file);
						/* 	    call error_leave_menu(); */
		curr_msgsp = null ();
		pos_line = "NONE";
		if file = "incoming" then xmail_data.mail_in_incoming = "0"b;
		goto START;
	     end;
	on condition (program_interrupt) go to START;
	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry;
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to clear user_io window. This is an internal programming error.");

START:
	redisplay_menu = "1"b;
	return_to_caller = "0"b;
	do while ("1"b);
	     if rtrim (pos_line) = "NONE" then xmail_data.mail_in_incoming = "0"b;
	     call ioa_$rsnnl ("Total messages: ^d", file_info, (0), mailbox.n_messages - mailbox.n_deleted_messages);
	     if curr_msgsp ^= null
	     then if curr_msgs.count > 1 then multiple_msgs = "1"b;
		else multiple_msgs = "0"b;
	     call ioa_$rsnnl ("Current message^[^ss^;^[s^]^]: ^a", position, (0), curr_msgsp = null, multiple_msgs, pos_line);
	     call xmail_get_choice_ (menup,
		"Mailbox: " || file,
		(file_info),
		(position),
		xmail_data.normal_usage,
		redisplay_menu,
		"",
		choice,
		code);
	     redisplay_menu = "0"b;

	     if code = 0
	     then do;
		     call PERFORM_OPTION (choice, redisplay_menu);
		     if return_to_caller
		     then do;
			     call leave_menu ();
			     return;
			end;
		end;
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now
	     then do;
		     call query_if_more_msgs ();
		     call leave_menu ();
		     go to EXIT;
		end;
	     else do;
		     call window_$bell (iox_$user_output, code);
		     if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot ring terminal bell. This is an internal programming error.");

		end;
	end;

EXIT:	return;
%page;
PERFORM_OPTION: proc (opt, redisplay);

	dcl     xmail_delete_msgs_	 entry (ptr, ptr, char (*), char (*));
	dcl     xmail_display_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_dprint_msgs_	 entry (ptr, ptr);
	dcl     xmail_file_msgs_$current_msgs entry (ptr, ptr, char (32) var, bit (1) aligned);
	dcl     xmail_forward_msg_	 entry (ptr, ptr);
	dcl     xmail_list_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_list_msgs_$selected entry (ptr, ptr, ptr);
          dcl     xmail_list_msgs_$set_seen_switch entry (ptr, ptr, bit (1) aligned);
	dcl     xmail_reply_msg_	 entry (ptr, ptr);
	dcl     xmail_select_msgs_	 entry (ptr, ptr, ptr, bit (2) aligned, char (*));
	dcl     xmail_select_msgs_$next entry (ptr, ptr, char (*));
	dcl     xmail_write_msgs_	 entry (ptr, ptr);
	dcl     xmail_Consult_Files_	 entry ();
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));


	dcl     deleted_msg_string	 char (25);
	dcl     opt		 fixed bin;
	dcl     message_num		 fixed bin;
	dcl     idx		 fixed bin;
	dcl     idx1		 fixed bin;
	dcl     dreply_msg_ptr	 ptr;
	dcl     counter		 fixed bin;
	dcl     redisplay		 bit (1) aligned;
          dcl     seen_msgsp             ptr;
          dcl     switch                 bit (1) aligned;
          dcl     switch_on_off          bit (2) aligned;
          dcl     SWITCH_ON              bit (2) aligned init ("10"b) int static options (constant);
	dcl     MAILBOX_EMPTY_MSG	 char (17) static options (constant) init
				 ("Mailbox is empty.");

	call window_$clear_window (iox_$user_output, code);
	go to OPT (opt);

OPT (1):						/* Display Messages Option */
	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	if curr_msgsp ^= null ()
	then call xmail_display_msgs_ (mailbox_ptr, curr_msgsp, iox_$user_output);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	return;

OPT (2):						/* Reply to Messages */
	if curr_msgsp ^= null ()
	then call xmail_reply_msg_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null ()
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;

OPT (3):						/* File Original Option */
	if curr_msgsp ^= null ()
	then do;
		call xmail_file_msgs_$current_msgs (mailbox_ptr, curr_msgsp, default_file, ALLOW_SELECTION);
		if default_file ^= ""
		then call delete_msgs;
	     end;
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;

OPT (4):						/* Delete Messages Option */
	if curr_msgsp ^= null ()
	then call delete_msgs;
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;


OPT (5):						/* Next Message Option */
	if curr_msgsp ^= null
	     | (NEW_MESSAGES () & curr_msgsp = null)
	then do;
		call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
		call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
	     end;
	else call ioa_ (MAILBOX_EMPTY_MSG);
	return;

OPT (6):						/* Select Messages Option */
	if curr_msgsp = null then
	    if NEW_MESSAGES () & curr_msgsp = null
	     then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	if curr_msgsp ^= null
	then do;
		call xmail_select_msgs_ (mailbox_ptr, curr_msgsp, seen_msgsp, switch_on_off, pos_line);
		call window_$clear_window (iox_$user_output, code);
		if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Unable to clear user_io window. This is an internal programming error.");

/* update and redisplay the new message line before list */

		if seen_msgsp ^= null
                    then do;
		     if switch_on_off = SWITCH_ON then switch = "1"b;
		     else switch = "0"b;
		     call xmail_list_msgs_$set_seen_switch (mailbox_ptr, seen_msgsp, switch);
		     free seen_msgsp -> curr_msgs;
end;
		else if curr_msgsp ^= null then do;
			if curr_msgs.count > 1
			then multiple_msgs = "1"b;
			else multiple_msgs = "0"b;
			call ioa_$rsnnl ("Current message^[^ss^;^[s^]^]: ^a", position, (0), curr_msgsp = null, multiple_msgs, pos_line);
			call xmail_sw_$update_position ((position));
			call xmail_sw_$redisplay ();
			
			call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
			end;
	end;
	else call ioa_ (MAILBOX_EMPTY_MSG);
	return;

OPT (7):						/* Display Summary of Current Messages Option */
	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	if curr_msgsp ^= null
	then call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	return;

OPT (8):						/* Display Summary of Messages Option */
	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	if curr_msgsp ^= null
	then call xmail_list_msgs_ (mailbox_ptr, curr_msgsp, iox_$user_output);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	return;

OPT (9):						/* Forward Messages */
	if curr_msgsp ^= null ()
	then call xmail_forward_msg_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);

	return;

OPT (10):						/* Undelete Messages Option */
	call xmail_undelete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, "");
	if curr_msgsp ^= null ()
	then do;
		do idx = 1 to curr_msgs.count;
		     message_num = curr_msgs.numbers (idx);
		     if mailbox.messages (message_num).message_ptr = null
		     then do;
			     call mail_system_$read_message (mailbox_ptr, message_num, code);
			     if code ^= 0
			     then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
			end;
		     dreply_msg_ptr = mailbox.messages (message_num).message_ptr;
		     deleted_msg_string = unique_chars_ ((dreply_msg_ptr -> message.header.message_id)) || ".reply";
		     do idx1 = 1 to no_of_entries;
			if deletes_array (idx1) = deleted_msg_string then deletes_array (idx1) = "";
		     end;
		end;
		if rtrim (file) = "incoming" then xmail_data.mail_in_incoming = "1"b;
	     end;
	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;

OPT (11):						/* File Copy Option */
	if curr_msgsp ^= null ()
	then call xmail_file_msgs_$current_msgs (mailbox_ptr, curr_msgsp, default_file, ALLOW_SELECTION);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;

OPT (12):						/* Print Messages Option */
	if curr_msgsp ^= null ()
	then call xmail_dprint_msgs_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;

OPT (13):						/* Write Messages Option */
	if curr_msgsp ^= null ()
	then call xmail_write_msgs_ (mailbox_ptr, curr_msgsp);
	else call ioa_ (MAILBOX_EMPTY_MSG);

	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);
	return;

OPT (14):						/* Process Filed Mail Option */
	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);

	redisplay = "1"b;
	xmail_data.foreign_mailbox = "1"b;
	call xmail_Consult_Files_ ();
	xmail_data.foreign_mailbox = "0"b;
	return;

OPT (15):						/* Send Mail Option */
	if NEW_MESSAGES () & curr_msgsp = null
	then call xmail_select_msgs_$next (mailbox_ptr, curr_msgsp, pos_line);

	what_next = "send_mail";
	return_to_caller = "1"b;
	return;

%page;
delete_msgs: proc;
	no_of_entries = old_no_of_entries + curr_msgs.count;
	call hcs_$set_bc_seg (deletes_ptr, no_of_entries * 225 + 36, code);
	counter = 0;
	do idx = (old_no_of_entries + 1) to no_of_entries;
	     counter = counter + 1;
	     message_num = curr_msgs.numbers (counter);
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		     call mail_system_$read_message (mailbox_ptr, message_num, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
		end;
	     dreply_msg_ptr = mailbox.messages (message_num).message_ptr;
	     deletes_array (idx) = unique_chars_ ((dreply_msg_ptr -> message.header.message_id)) || ".reply";
	     call hcs_$status_minf ((mail_dir), (deletes_array (idx)), (0), (0), (0), code);
	     if code = 0 then call ioa_ ("^/   The deferred reply for message no.^d was discarded.^/   To retrieve it, select the ""Retrieve Messages"" option.^/", message_num);
	end;

	old_no_of_entries = no_of_entries;
	call xmail_delete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, (file));
	return;
     end delete_msgs;

NEW_MESSAGES: proc returns (bit (1));

	dcl     new_flag		 bit (1);

	call mail_system_$read_new_messages (mailbox_ptr, (0), n_new_msgs, (0), status);
	if status ^= 0 & status ^= mlsys_et_$no_more_messages
	then call xmail_error_$no_code (status, NAME, "q", "Unable to read mail file. This is an internal programming error.");
	if n_new_msgs = 1
	then call ioa_ ("A new message has arrived.");
	else if n_new_msgs > 1
	then call ioa_ ("^d new messages have arrived.", n_new_msgs);

	if n_new_msgs = 0 then new_flag = "0"b;
	else do;
		new_flag = "1"b;
		if rtrim (file) = "incoming"
		then xmail_data.mail_in_incoming = "1"b;
	     end;
	return (new_flag);
     end NEW_MESSAGES;


     end PERFORM_OPTION;
%page;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin;

	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));

	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");
	call xmail_display_help_ (NAME || ".gi.info",
	     translate (OPTION_NAMES (opt), "_", " "), code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");

     end EXPLAIN_OPTION;
%page;
GET_MENU: proc;

	dcl     code		 fixed bin (35);
	dcl     TITLE		 init ("Process Incoming Mail") char (21)
				 static options (constant);


	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));

	call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menup, code);
	if code ^= 0
	then do;
		call xmail_error_$code_last (xmail_err_$int_prog_err, NAME, "l", "Unable to get the ""Executive Mail"" menu.");
		call error_leave_menu ();


	     end;
	call xmail_display_menu_ (menup, 2, code);

     end GET_MENU;

error_leave_menu: proc ();

	call leave_menu ();
	go to EXIT;

     end error_leave_menu;


query_if_more_msgs: proc ();

	dcl     xmail_select_msgs_$new entry (ptr, ptr, char (*));
	dcl     mail_system_$get_message_counts entry (char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
	if mailbox_ptr ^= null
	then do;
		call mail_system_$get_message_counts (dir, (file), INCLUDE_BY_TYPE, n_total_msgs, n_ordinary_msgs, n_interactive_msgs, code);
		if code = 0 then do;
		          if auto_open_options.message_selection_mode = ALL_MESSAGES then
			n_new_msgs = n_total_msgs - mailbox.n_messages;
			else n_new_msgs = n_ordinary_msgs - mailbox.n_messages;      
			if n_new_msgs > 0		 
			then do;			 
				xmail_data.mail_in_incoming = "1"b;
				if want_to_examine_more ()
				then do;

					call xmail_select_msgs_$new (mailbox_ptr, curr_msgsp, pos_line);
					call ioa_ ("The newly arrived messages are now the current messages.");
					go to START;
				     end;
			     end;
		     end;
		else if code ^= mlsys_et_$no_s_permission & code ^= mlsys_et_$no_r_permission
		then call xmail_error_$no_code (code, NAME, "q", "Unable to read mail file. This is an internal programming error.");
	     end;
     end query_if_more_msgs;

leave_menu: proc ();

	if mailbox_ptr ^= null
	then do;

	     if cleanup_signalled then call xmail_undelete_msgs_ (mailbox_ptr, curr_msgsp, pos_line, "");
	     xmail_data.cleanup_signalled = "0"b;
		auto_close_options.version = CLOSE_OPTIONS_VERSION_2;
		auto_close_options.flags.perform_deletions = "1"b;
		auto_close_options.flags.report_deletion_errors = "0"b;
		auto_close_options.flags.mbz = "0"b;
		call mail_system_$close_mailbox (mailbox_ptr, addr (auto_close_options), code);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, "l", "Unable to close user mailbox. This is an internal programming error.");
	     end;

	xmail_data.foreign_mailbox = "0"b;
	if curr_msgsp ^= null ()
	then do;
		free curr_msgs;
		curr_msgsp = null ();
	     end;
	if (deletes_ptr ^= null () & no_of_entries ^= 0) then call xmail_delete_dreply_ (deletes_ptr);
	old_no_of_entries = 0;

     end leave_menu;


want_to_examine_more: proc () returns (bit (1) aligned);

	dcl     yes_sw		 bit (1) aligned;

	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);

	call ioa_ ("^d new message^[s^] ^[have^;has^] arrived.", n_new_msgs, n_new_msgs > 1, n_new_msgs > 1);

	call xmail_get_str_$yes_no ("Do you still wish to quit?", yes_sw);
	return (^yes_sw);

     end want_to_examine_more;

%page;
%include menu_dcls;
%page;
%include xmail_responses;
%page;
%include xmail_data;
%page;
%include window_dcls;
%page;
%include mlsys_open_options;
%page;
%include mlsys_close_options;
%page;
%include mlsys_mailbox;
%page;
%include xmail_windows;
%page;
%include xmail_curr_msg_info;
%page;
%include mlsys_message;
%page;

     end xmail_Process_Mail_;





		    xmail_Review_Defaults_.pl1      09/02/88  0759.6rew 09/02/88  0735.8      479790



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



/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-12  JG Backs: Split the Personalize Executive Mail menu into one
     small menu with 3 options.  Each of those options will display another
     menu.  The internal procedures for each of the original options plus new
     options being added were changed to entrypoints to be executed by the new
     menu modules: xmail_Review_Printing_.pl1, xmail_Review_Outgoing_.pl1, and
     xmail_Review_Processing_.pl1.
     85-03-27  JG Backs: Deleted duplicate code in the different entrypoints
     by using a call to internal procedure CHECK_VALUE_YN if valid responses
     to options are yes, no, or ask.  Modified CHECK_VALUE_YN to allow case
     insensitive responses, as well as "ask" and "a" as valid responses if flag
     is set.  Moved ASK, A, SET, and S constants to xmail_responses.incl.pl1.
     Added input parameters of option names to the entrypoints and additional
     info names to support the new options.
     85-04-17 JG Backs: Replaced all the Message Facility commands
     (accept_messages, defer_messages, print_messages) with calls to the new
     xmail_im_mgr_ module which uses the new Message Facility entrypoints for
     these functions.
  2) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-19 JG Backs: Modified multics_mode entrypoint to get the value of
     always_escape_yn after the multics mode option is changed, in case the
     default for function keys has to change because of the new # of function
     keys needed.  Introduced bug when creating entrypoint from procedure.
     It was getting the multics_mode_yn value instead.
     85-04-25 JG Backs: Created new entrypoints related to getting the new
     values for each of the printing options: get_new_header, get_new_station,
     get_new_destination, get_new_copies, get_new_margin, get_new_notify.
     xmail_print_ will call these to obtain new values and not change the
     values in the value segment permanently.  Modified the existing
     entrypoints for the printing options to also call the new ones to keep
     the interface consistant for the user.
     85-04-26 JG Backs: Modified get_new_notify entrypoint to translate and
     test the new value instead of the old value.  Modified get_new_station
     to test the new value for a valid request_type, instead of changing the
     old value.  No changes to the old value should occur during get_new....
     entrypoints.  Bugfixes.
  3) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Modified include_original entrypoint to ask if the original should be
     displayed in the upper window. The new value name is ORIGINAL_UP_WINDOW_YN.
  4) change(87-01-16,Blair), approve(87-02-05,MCR7618),
     audit(87-04-14,RBarstad), install(87-04-26,MR12.1-1025):
     Make a new entry for including interactive messages in the mailbox.
     MSGS_AS_MAIL.
  5) change(88-06-27,Blair), approve(88-07-27,MCR7959),
     audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098):
     Allow full_name to be changed when the xmail_data.value seg is in the
     pdir.
                                                   END HISTORY COMMENTS */


xmail_Review_Defaults_: proc;

/* BEGIN DESCRIPTION

function:	This procedure provides the xmail user with a menu for the
	purpose of inspecting and updating default values which control
	aspects of the operation of xmail.

history:

   Written 7/16/81 by Paul Kyzivat 

   Modified by R. Ignagni Oct 1981 to add REVIEW_ACKNOWLEDGE 

   Extensively modified by R. Ignagni 3/4/82

   83-08-08 DJ Schimke: Changed all references of Person_id.xmail to 
   Person_id.mlsys. These references are in the delegation of authority code
   which is not used in this version, but may be used in the future. Deleted
   unreferenced variables and declared addr, before, index, rtrim and verify
   builtins.

   83-09-14 DJ Schimke: Modified to allow "y", "n", and "a" as well as "yes",
   "no", and "ask" as legal values for the YES/NO/ASK type options. TR12009

   83-09-16 DJ Schimke: Modified the printout station code to allow the 
   keyword "default" which returns the printout station to the original 
   site default by deleting the option from the value seg. phx13205

   83-10-10 DJ Schimke: replaced the calls to xmail_get_line with calls to 
   xmail_get_str_ which also handles the help function code.

   83-11-23 DJ Schimke: Added a new personalization option "Outgoing Savefile" 
   which allows selection of where to file save messages. This also solves the
   discrepancy between the different actions resulting from setting "Save
   Outgoing Messages" to "yes" vs never having set "Save Outgoing Messages".  
   The former always saved to "outgoing" while the latter always asked where.

   83-12-07 DJ Schimke Modified the code to report an error on a non-zero code
   from xmail_value_$get since the defaults for "Save-Outgoing-Messages",
   "Outgoing-Savefile", and "Acknowledge" are now guaranteed to exist by the
   code in xmail_dir_manager_. Temporarily removed the "Outgoing Savefile" 
   option. It will not be available until the MR11.0 release.

   84-02-17 DJ Schimke: Reinstated the new option "Save-Outgoing-Messages"
   for EXL version 2.1.

   84-07-03  DJ Schimke: Modified the call to xmail_create_menu_ to add the
   N_COLUMNS parameter. 

   84-09-04  JG Backs: Modified to add 6 new personalization options to the
   menu and 6 new internal procedures to handle the options.

   84-09-19  JG Backs: Added function_key_data and terminal_info include files
   to define the structures for function keys when changing from escape 
   sequences to function keys.

   84-09-24  JG Backs: Added "-brief" control argument to print_messages 
   command so the message "You have no messages" would not print. This is to
   make xmail compatible with the new message facility for mr11.

   84-10-02  JG Backs: Added a test in REVIEW_INTERACTIVE_MSGS proc so that
   when a user sets the option to no, the call to print messages will not
   be executed if the user had invoked xmail with the "-nim" argument.

   84-11-07  JG Backs: Made the user messages clearer and more consistant
   when the new personalize options are chosen and lengthened the name of
   the terminal info structure to this_terminal_info.  Also removed duplicate
   constants, used in determining values from the xmail value segment, by
   using rtrim on the info constants.  Added a trailing underscore to the
   call and declaration of module xmail_default_fkeys_.  Audit change.


   
END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     answer_yn		 char (3) var;	/* value yes, no, or ask */
	dcl     changed_value	 bit (1) aligned;
	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     create		 bit (1) aligned;
	dcl     dir		 char (168);
	dcl     display_needed	 bit (1) aligned;
	dcl     exists		 bit (1) aligned;
	dcl     generic_type	 char (32);
	dcl     new_full_name	 char (32);	/* contents of full name */
	dcl     prefix		 char (32) var;
	dcl     prompt_string	 char (200) var;
	dcl     response		 char (200) varying;
	dcl     response_bin	 fixed bin;         /* binary number of copies or left margin spaces */
	dcl     save_mailbox	 char (32) varying;
	dcl     status		 fixed bin (35);
	dcl     unused_return_length	 fixed bin;
	dcl     use_default_fkeys	 bit (1) aligned;	/* flag for escape */
	dcl     user_copies 	 char (2);          /* number of copies to print */
	dcl     user_destination	 char (24);
	dcl     user_header		 char (64);
	dcl     user_lmargin 	 char (2);          /* number of spaces to indent left margin when printing */
	dcl     user_notify		 char (3);	/* value yes or no */
	dcl     user_request_type	 char (24);
	dcl     value_name		 char (32) var;	/* name in xmail value segment */
	dcl     valid		 bit (1) aligned;
	dcl     yes_sw		 bit (1) aligned;

	dcl     1 this_terminal_info	 like terminal_info;/* this session */

/* CONSTANTS */

	dcl     ACCEPT_NEW		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     ACCEPT_OLD		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     COPIES_LIMIT	 fixed bin int static options (constant) init (30);
	dcl     COPIES_NO_GOOD         char (46) int static options (constant) init ("You may only enter a number from 1 through 30.");
	dcl     EIGHT_FKEYS		 fixed bin int static options (constant) init (8);
	dcl     FULL_MAILFILE_SUFFIX	 char (7) int static options (constant) init (".sv.mbx");
	dcl     FULL_NAME		 char (11) int static options (constant) init ("full_name._");
	dcl     LOG		 char (1) int static options (constant) init ("l");
	dcl     LOWERCASE_YN_ASK       char (8) int static options (constant) init ("yesnoask");
	dcl     MAILFILE_SUFFIX	 char (6) int static options (constant) init ("sv.mbx");
	dcl     MARGIN_LIMIT	 fixed bin int static options (constant) init (20);
	dcl     MARGIN_NO_GOOD         char (46) int static options (constant) init ("You may only enter a number from 0 through 20.");
	dcl     NAME		 init ("xmail_Review_Defaults_") char (22) int static options (constant);
	dcl     N_COLUMNS		 fixed bin int static options (constant) init (2);
	dcl     NUMERICS               char (10) int static options (constant) init ("0123456789");
	dcl     (
	/*** names of infos ***/
/*	        PRINTING_QUESTION	 init ("printing_question"),    not used, retained for documentation 
	        OUTGOING_QUESTION	 init ("outgoing_question"),    not used, retained for documentation 
	        PROCESSING_QUESTION	 init ("processing_question"),  not used, retained for documentation */
	        HEADER_QUESTION	 init ("heading_question"),
	        DESTINATION_QUESTION	 init ("destination_question"),
	        STATION_QUESTION	 init ("station_question"),
	        LONG_DESTINATION	 init ("destination_too_long"),
	        LONG_HEADER		 init ("heading_too_long"),
	        LONG_NAME		 init ("full_name_too_long"),
	        RQT_TOO_LONG	 init ("station_name_too_long"),
	        RQT_UNKNOWN		 init ("unknown_station"),
	        RQT_NOT_PRINT	 init ("wrong_type_station"),
	        ACKNOWLEDGE_YN	 init ("acknowledge_yn"),
	        ALWAYS_ESCAPE_YN	 init ("always_escape_keys_yn"),
	        CONFIRM_PRINT_YN	 init ("confirm_print_yn"),
	        COPIES_QUESTION	 init ("copies_question"),
	        FULL_NAME_QUESTION	 init ("full_name_question"),
	        INTERACTIVE_MSGS_YN	 init ("interactive_msgs_yn"),
	        LISTS_AS_MENUS_YN	 init ("lists_as_menus_yn"),
	        LEFT_MARGIN_QUESTION	 init ("left_margin_question"),
	        MULTICS_MODE_YN	 init ("multics_mode_yn"),
	        NOTIFY_YN   	 init ("notify_yn"),
	        REMOVE_MENUS_YN	 init ("remove_menus_yn"),
	        SAVE_MESSAGE_YN	 init ("save_message_yn"),
	        FILE_ORIGINAL_YN       init ("file_original_yn"),
	        INCLUDE_ORIGINAL_YN    init ("include_original_yn"),
	        ORIGINAL_UP_WINDOW_YN  init ("original_up_window_yn"),
	        SAVE_MAILBOX_HELP	 init ("save_mailfile"),
                  MSGS_AS_MAIL_YN        init ("msgs_as_mail_yn")
	        )			 char (32) int static options (constant);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "Printing Options",
				 "Outgoing Message Options",
				 "Processing Options"
				 ) dim (3) char (28) var;
	dcl     PERMANENT		 bit (36) aligned int static options (constant) init ("01"b);
          dcl     PERPROCESS             bit (36) aligned int static options (constant) init ("10"b);
	dcl     SEVEN_FKEYS		 fixed bin int static options (constant) init (7);
	dcl     TITLE		 init ("Personalize Executive Mail") char (26)
				 int static options (constant);
	dcl     UPPERCASE_YN_ASK       char (8) int static options (constant) init ("YESNOASK");

/* EXTERNAL STATIC */

	dcl     iox_$user_io	 ptr ext static;
	dcl     iox_$user_output	 ptr ext static;
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);
	dcl     error_table_$oldnamerr fixed bin (35) ext static;
          dcl     error_table_$no_w_permission fixed bin(35) ext static;
	dcl     error_table_$bad_conversion fixed bin (35) ext static;

/* INTERNAL STATIC */

	dcl     menu		 int static ptr init (null);

/* ENTRIES */

	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     iod_info_$generic_type entry (char (*), char (32), fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     mlsys_utils_$create_savebox entry (char (*), char (*), fixed bin (35));
	dcl     ttt_info_$function_key_data entry (char (*), ptr, ptr, fixed bin (35));
	dcl     value_$get		 entry () options (variable);
	dcl     value_$set		 entry () options (variable);
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
	dcl     xmail_default_fkeys_	 entry () returns (ptr);
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_get_str_	 entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_im_mgr_$defer_messages entry ();
	dcl     xmail_im_mgr_$print_messages entry ();
	dcl     xmail_im_mgr_$restore_original entry ();
	dcl     xmail_print_$get_heading entry (char (*), fixed bin (35));
	dcl     xmail_print_$set_heading entry (char (*), fixed bin (35));
	dcl     xmail_print_$get_destination entry (char (*), fixed bin (35));
	dcl     xmail_print_$set_destination entry (char (*), fixed bin (35));
	dcl     xmail_print_$get_request_type entry (char (*), fixed bin (35));
	dcl     xmail_print_$set_request_type entry (char (*), fixed bin (35));
	dcl     xmail_print_$get_copies entry (char (*), fixed bin (35));
	dcl     xmail_print_$set_copies entry (char (*), fixed bin (35));
	dcl     xmail_print_$get_left_margin entry (char (*), fixed bin (35));
	dcl     xmail_print_$set_left_margin entry (char (*), fixed bin (35));
	dcl     xmail_print_$get_notify entry (char (*), fixed bin (35));
	dcl     xmail_print_$set_notify entry (char (*), fixed bin (35));
	dcl     xmail_Review_Defaults_$get_new_copies entry (char (*), char (*) var, fixed bin);
	dcl     xmail_Review_Defaults_$get_new_destination entry (char (*), char (*) var);
	dcl     xmail_Review_Defaults_$get_new_header entry (char (*), char (*) var);
	dcl     xmail_Review_Defaults_$get_new_margin entry (char (*), char (*) var, fixed bin);
	dcl     xmail_Review_Defaults_$get_new_notify entry (char (*), char (*), char (*) var);
	dcl     xmail_Review_Defaults_$get_new_station entry (char (*), char (*) var);
	dcl     xmail_Review_Printing_ entry ();
	dcl     xmail_Review_Processing_ entry ();
	dcl     xmail_Review_Outgoing_ entry ();
	dcl     xmail_select_file_	 entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, char (168),
				 char (32) var, bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_value_$delete	 entry (char (*), fixed bin (35));
	dcl     xmail_value_$get	 entry (char (*), char (*) var, fixed bin (35));
	dcl     xmail_value_$set	 entry (char (*), char (*) var, char (*) var, fixed bin (35));
	dcl     xmail_window_manager_$reconnect entry options (variable);

/* CONDITIONS */

	dcl     (conversion, program_interrupt, quit, size, xmail_redisplay_menu) condition;

/* BUILTINS */

	dcl     (addr, convert, length, null, rtrim, translate, verify) builtin;

/* INCLUDE FILES */

%include menu_dcls;
%page;
%include xmail_data;
%page;
%include xmail_help_infos;
%page;
%include xmail_responses;
%page;
%include xmail_windows;
%page;
%include window_dcls;
%page;
%include function_key_data;
%page;
%include terminal_info;

/* BEGIN */
	on condition (xmail_redisplay_menu) begin;
		if menu ^= null
		then call menu_$display (xmail_windows.menu.iocb, menu, (0));
	     end;

	if menu = null then do;
	     call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menu, code);
	     if code ^= 0 then call xmail_error_$no_code (status, NAME, "q",
		     "A programming error has been detected which prevents " ||
		     "the use of the ^a menu.", TITLE);

	end;

	on condition (program_interrupt) go to START;
	on condition (quit) begin;
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	call window_$clear_window (iox_$user_output, (0));
	call ioa_ (" ");

START:	display_needed = "1"b;
	do while ("1"b);
	     call xmail_get_choice_ (menu, "", "", "", xmail_data.normal_usage,
		display_needed, "", choice, code);
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now then go to EXIT;
	     else call window_$bell (iox_$user_output, (0));
	end;
EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* PARAMETERS */

	dcl     redisplay		 bit (1) aligned parameter;
	dcl     opt		 fixed bin parameter;

/* BEGIN PERFORM_OPTION */

	call window_$clear_window (iox_$user_output, (0));
	go to OPT (opt);

OPT (1):	redisplay = "1"b;
	call xmail_Review_Printing_;
	go to OPT_EXIT;

OPT (2):	redisplay = "1"b;
	call xmail_Review_Outgoing_;
	go to OPT_EXIT;

OPT (3):	redisplay = "1"b;
	call xmail_Review_Processing_;
	go to OPT_EXIT;

OPT_EXIT: return;
     end PERFORM_OPTION;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin parameter;

	call window_$clear_window (iox_$user_output, (0));
	call xmail_display_help_ (REVIEW_DEFAULTS_HELP,
	     translate (OPTION_NAMES (opt), "_", " "),
	     (0));

     end EXPLAIN_OPTION;

CHECK_VALUE_YN: proc (cvy_value_name, cvy_option_name, cvy_help_name, cvy_ask_sw);

/* Function: This procedure gets the value assigned to cvy_value_name, allows
             the user to change it, and then sets the new value. Yes, no and
             RETURN are the valid responses.  If cvy_ask_sw is set, ask is also
             a valid response.  Values are from xmail_data.value segment.
*/

/* PARAMETERS */

	dcl     cvy_value_name		 char (*); /* input */
	dcl     cvy_option_name		 char (*); /* input */
	dcl     cvy_help_name		 char (*); /* input */
	dcl     cvy_ask_sw		           bit (1);  /* input */

/* BEGIN  CHECK_VALUE_YN */

	changed_value = "0"b;

	call xmail_value_$get (cvy_value_name, answer_yn, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", cvy_option_name);
	     go to CHECK_VALUE_YN_EXIT;
	end;

	call ioa_ ("^a is currently set to: ^a", cvy_option_name, answer_yn);
	call ioa_ ("You may now reset option " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");
	valid = "0"b;
	do while (^valid);
	     call ioa_$rsnnl (cvy_option_name || " ^[(enter ""yes"", ""no"", or ""ask"")^;(enter ""yes"" or ""no"")^]: ", prompt_string, unused_return_length, cvy_ask_sw);

 	     call xmail_get_str_ (prompt_string, "", REVIEW_DEFAULTS_HELP, cvy_help_name, response);

/* Allowable responses are case insensitive yes, y, no, n, ??, ?, and RETURN,
   plus a and ask if ask switch is set. */

	     response = translate (response, LOWERCASE_YN_ASK, UPPERCASE_YN_ASK);
	     if response = Y then response = YES;
	     if response = N then response = NO;
	     if response = A then response = ASK;
	     if length (response) = 0 then valid = "1"b;
	     else if response = YES | response = NO
	     then valid = "1"b;
	     else if cvy_ask_sw  & response = ASK         /* allow ask */
	     then valid = "1"b;
	     else if response = LIST
	     then call ioa_ ("^a is currently set to: ^a", cvy_option_name, answer_yn);
	     else do;
		valid = "0"b;
		if cvy_ask_sw
		then call ioa_ ("You may only enter ""yes"", ""no"", or ""ask"", followed by a RETURN.^/  Enter ? if you need help.");
		else call ioa_ ("You may only enter ""yes"" or ""no"", followed by a RETURN.^/  Enter ? if you need help.");
	     end;
	end;					/* end of do */

	if length (response) = 0 | response = answer_yn
	then call ioa_ ("^a remains unchanged.", cvy_option_name);
	else do;
	     call xmail_value_$set (cvy_value_name, (response), answer_yn, status);
	     if status = 0
	     then changed_value = "1"b;
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", cvy_option_name);
	end;

CHECK_VALUE_YN_EXIT:
     return;

     end CHECK_VALUE_YN;

CHANGE_TO_DEFAULT_KEYS: proc ();

/* Function: Change from using function keys to using escape sequences. Free
             the previous allocation pointer and call xmail_default_fkeys_
             module to allocate new structure. */

/* BEGIN */

	free xmail_data.function_key_data_ptr -> function_key_data;

	xmail_data.function_key_data_ptr = xmail_default_fkeys_ ();
	xmail_data.normal_usage = "(For help, press ESC, then ""?"")";

     end CHANGE_TO_DEFAULT_KEYS;

TEST_AND_CHANGE_FUNCTION_KEYS: proc ();

/* Function: Check terminal data to make sure it can support the number of
             function keys for this invocation of xmail. Free the previous
             allocation pointer and use function_key_data structure if
             possible. */

/* BEGIN */

	use_default_fkeys = "0"b;

/* Get terminal data (function keys etc.). */

	this_terminal_info.version = terminal_info_version;
	call iox_$control (iox_$user_io, "terminal_info", addr (this_terminal_info), code);
	if code ^= 0
	then call xmail_error_$no_code (code, NAME, "q", "Cannot get terminal info to change function keys");

	call ttt_info_$function_key_data (this_terminal_info.term_type, null, function_key_data_ptr, code);
	if code ^= 0
	then use_default_fkeys = "1"b;
	else if function_key_data.highest < xmail_data.n_fkeys_used
	then use_default_fkeys = "1"b;

	if use_default_fkeys
	then do;
	     free function_key_data_ptr -> function_key_data;
	     call CHANGE_TO_DEFAULT_KEYS;
	     call ioa_ ("WARNING: The terminal you are using does not support enough function keys.");
	     call ioa_ ("         Escape sequences will be used during this session.");
	end;
	else do;
	     free xmail_data.function_key_data_ptr -> function_key_data;
	     xmail_data.function_key_data_ptr = function_key_data_ptr;
	     xmail_data.normal_usage = "(For help, press F1)";
	end;


     end TEST_AND_CHANGE_FUNCTION_KEYS;

CONVERT: proc (c_value_char, c_value_bin, c_status);

/*
     Converts a character value to a binary value so it can be tested
     against limits.  Used for copies and left margin.
*/

/* PARAMETERS */

         dcl     c_value_char      char (*) varying;        /* input */
         dcl     c_value_bin       fixed bin;               /* output binary */
         dcl     c_status          fixed bin (35);          /* output */

/* BEGIN */

         c_status = 0;

         on conversion, size 
	     c_status = error_table_$bad_conversion;

         c_value_bin = convert (c_value_bin, c_value_char);

         revert conversion, size;         
         return;

     end CONVERT;

minus_suffix: proc (name, suffix) returns (char (*) var);

/* PARAMETERS */

	dcl     name		 char (*);
	dcl     suffix		 char (*);

/* AUTOMATIC */

	dcl     reverse_name	 char (length (name)) var;
	dcl     reverse_suffix	 char (length (suffix)) var;

/* BUILTINS */

	dcl     (after, index, length, reverse, rtrim) builtin;

/* BEGIN minus_suffix */

	reverse_name = reverse (rtrim (name));
	reverse_suffix = reverse (rtrim (suffix));

	if index (reverse_name, reverse_suffix || ".") ^= 1
	then return (name);
	else return (reverse (after (reverse_name, reverse_suffix || ".")));

     end minus_suffix;

/* ENTRYPOINTS */

/*
     The following are the entrypoints called to change the printing options
     in the personalization menu.
*/

header: entry (h_option_name);

/* PARAMETERS */

	dcl     h_option_name                 char (*);   /* input option name */

/* BEGIN */

	user_header = "";

	call xmail_print_$get_heading (user_header, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", h_option_name);
	     go to header_exit;
	end;

          call xmail_Review_Defaults_$get_new_header (user_header, response);

	if length (response) = 0 | response = user_header
	then call ioa_ ("^a remains unchanged.", h_option_name);
	else do;
	     user_header = response;
	     call xmail_print_$set_heading (user_header, status);
	     if status = 0
	     then call ioa_ ("The heading has been changed to: ^a", user_header);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", h_option_name);
	end;

header_exit: return;

get_new_header: entry (gnh_old_header, gnh_new_header);

/*
     This entrypoint is called by both xmail_print_ and xmail_Review_Defaults_
     to allow the user to enter a new value.
*/
	      
/* PARAMETERS */

	dcl     gnh_old_header                char (*);   /* input */
	dcl     gnh_new_header                char (*) var;/* output */

/* BEGIN */

	gnh_new_header = "";

	call ioa_ ("^[No heading has been defined to label hardcopy printouts.^;The heading used to label hardcopy printouts is: ^a", gnh_old_header = "", gnh_old_header);

	call ioa_ ("You may now enter a new heading, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");
	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("New header:  ", "", REVIEW_DEFAULTS_HELP, HEADER_QUESTION, gnh_new_header);
	     if gnh_new_header = LIST
	     then call ioa_ ("^[There is no defined heading.^;The defined heading is:  ^a^]", gnh_old_header = "", gnh_old_header);
	     else if length (gnh_new_header) > length (gnh_old_header)
	     then call xmail_display_help_ (REVIEW_DEFAULTS_HELP, LONG_HEADER, (0));
	     else valid = "1"b;
	end;

          return;
	

destination: entry (d_option_name);

/* PARAMETERS */

	dcl     d_option_name                 char (*);   /* input option name */

/* BEGIN */

	user_destination = "";

	call xmail_print_$get_destination (user_destination, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", d_option_name);
	     go to destination_exit;
	end;

          call xmail_Review_Defaults_$get_new_destination (user_destination, response);

	if length (response) = 0 | response = user_destination
	then call ioa_ ("^a remains unchanged.", d_option_name);
	else do;
	     user_destination = response;
	     call xmail_print_$set_destination (user_destination, status);
	     if status = 0
	     then call ioa_ ("The destination has been changed to: ^a", user_destination);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", d_option_name);
	end;

destination_exit: return;

get_new_destination: entry (gnd_old_destination, gnd_new_destination);

/*
     This entrypoint is called by both xmail_print_ and xmail_Review_Defaults_
     to allow the user to enter a new value.
*/
	      
/* PARAMETERS */

	dcl     gnd_old_destination         char (*);     /* input */
	dcl     gnd_new_destination         char (*) var; /* output */

/* BEGIN */

	gnd_new_destination = "";

          call ioa_ ("^[No destination has been defined to label hardcopy printouts.^;The destination used to label hardcopy printouts is: ^a.^]", gnd_old_destination = "", gnd_old_destination);

	call ioa_ ("You may now enter a new destination, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");
	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("New destination:  ", "", REVIEW_DEFAULTS_HELP, DESTINATION_QUESTION, gnd_new_destination);
	     if gnd_new_destination = LIST
               then call ioa_ ("^[There is no defined destination.^;The defined destination is: ^a.^]", gnd_old_destination = "", gnd_old_destination);

	     else if length (gnd_new_destination) > length (gnd_old_destination)
	     then call xmail_display_help_ (REVIEW_DEFAULTS_HELP, LONG_DESTINATION, (0));
	     else valid = "1"b;
	end;

          return;

station: entry (s_option_name);

/* PARAMETERS */

	dcl     s_option_name                 char (*);   /* input option name */

/* BEGIN */

	user_request_type = "";

	call xmail_print_$get_request_type (user_request_type, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", s_option_name);
	     go to station_exit;
	end;

          call xmail_Review_Defaults_$get_new_station (user_request_type, response);

	if length (response) = 0 | response = user_request_type
	then call ioa_ ("^a remains unchanged.", s_option_name);
	else do;
	     if response ^= "default" 
	     then do;
		user_request_type = response;
		call xmail_print_$set_request_type (user_request_type, status);
	     end;
	     else do;
		user_request_type = "system default";
		call xmail_value_$delete ("dprint_request_type", status);
		if status = error_table_$oldnamerr then status = 0;
	     end;

	     if status = 0
	     then call ioa_ ("The station has been changed to: ^a", user_request_type);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", s_option_name);
	end;

station_exit: return;

get_new_station: entry (gns_old_request_type, gns_new_request_type);

/*
     This entrypoint is called by both xmail_print_ and xmail_Review_Defaults_
     to allow the user to enter a new value.
*/
	      
/* PARAMETERS */

	dcl     gns_old_request_type          char (*);    /* input */
	dcl     gns_new_request_type          char (*) var;/* output */

/* BEGIN */

	gns_new_request_type = "";

	call ioa_ ("^[Your output is printed at the system default output station^;The station used for your printouts is: ^a^]", gns_old_request_type = "", gns_old_request_type);

	call ioa_ ("You may now enter a new station, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");
	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("New printout station:  ", "", REVIEW_DEFAULTS_HELP, STATION_QUESTION, gns_new_request_type);
	     if length (gns_new_request_type) = 0 then valid = "1"b;
	     else if gns_new_request_type = LIST
	     then call ioa_ ("^[There is no defined station.^;The defined station is:  ^a^]", gns_old_request_type = "", gns_old_request_type);
	     else if gns_new_request_type = "default"
	     then valid = "1"b;
	     else do;
		if length (gns_new_request_type) > length (gns_old_request_type)
		then call xmail_display_help_ (REVIEW_DEFAULTS_HELP, RQT_TOO_LONG, (0));
		else do;
		     call iod_info_$generic_type ((gns_new_request_type), generic_type, status);
		     if status ^= 0
		     then call xmail_display_help_ (REVIEW_DEFAULTS_HELP, RQT_UNKNOWN, (0));
		     else if generic_type ^= "printer"
		     then call xmail_display_help_ (REVIEW_DEFAULTS_HELP, RQT_NOT_PRINT, (0));
		     else valid = "1"b;
		end;
	     end;
	end;

          return;

notify: entry (n_option_name);
	      
/* PARAMETERS */

	dcl     n_option_name                  char (*);  /* input option name */

/* BEGIN notify */

	user_notify = "";

	call xmail_print_$get_notify (user_notify, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", n_option_name);
	     go to notify_exit;
	end;

          call xmail_Review_Defaults_$get_new_notify (n_option_name, user_notify, response);

	if length (response) = 0 | response = user_notify
	then call ioa_ ("^a remains unchanged.", n_option_name);
	else do;
	     user_notify = response;
	     call xmail_print_$set_notify (user_notify, status);
	     if status = 0
	     then call ioa_ ("You will ^[be^;not be^] notified by message when printing is done.", response = YES);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", n_option_name);
	end;

notify_exit: return;

get_new_notify: entry (gnn_option_name, gnn_old_notify, gnn_new_notify);

/*
     This entrypoint is called by both xmail_print_ and xmail_Review_Defaults_
     to allow the user to enter a new value.
*/
	      
/* PARAMETERS */

	dcl     gnn_option_name               char (*);    /* input */
	dcl     gnn_old_notify                char (*);    /* input */
	dcl     gnn_new_notify                char (*) var;/* output */

/* BEGIN */

	gnn_new_notify = "";

	call ioa_ ("^a is currently set to: ^a", gnn_option_name, gnn_old_notify);

	call ioa_ ("You may now reset option, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");

	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("Do you want to be notified after printing? (enter ""yes"" or ""no""):  ", "", REVIEW_DEFAULTS_HELP, NOTIFY_YN, gnn_new_notify);

/* Allowable responses are case insensitive yes, y, no, n, ??, ?, RETURN. */

	     gnn_new_notify = translate (gnn_new_notify, LOWERCASE_YN_ASK, UPPERCASE_YN_ASK);
	     if gnn_new_notify = Y then gnn_new_notify = YES;
	     if gnn_new_notify = N then gnn_new_notify = NO;
	     if length (gnn_new_notify) = 0 then valid = "1"b;
	     else if gnn_new_notify = YES | gnn_new_notify = NO
	     then valid = "1"b;

	     else if gnn_new_notify = LIST
	     then	call ioa_ ("^a is currently set to: ^a", gnn_option_name, gnn_old_notify);
	     else call ioa_ ("You may only enter ""yes"" or ""no"", followed by a RETURN.^/  Enter ? if you need help.");
	end;

          return;

copies: entry (c_option_name);

/* PARAMETERS */

	dcl     c_option_name                 char (*);   /* input option name */

/* BEGIN */

	user_copies = "";

	call xmail_print_$get_copies (user_copies, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", c_option_name);
	     go to copies_exit;
	end;

          call xmail_Review_Defaults_$get_new_copies (user_copies, response, response_bin);

	if length (response) = 0 | response = user_copies
	then call ioa_ ("^a remains unchanged.", c_option_name);
	else do;
	     user_copies = response;
	     call xmail_print_$set_copies (user_copies, status);
	     if status = 0
	     then call ioa_ ("The number of copies has been changed to: ^a", user_copies);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", c_option_name);
	end;

copies_exit: return;

get_new_copies: entry (gnc_old_copies, gnc_new_copies, gnc_new_copies_bin);

/*
     This entrypoint is called by both xmail_print_ and xmail_Review_Defaults_
     to allow the user to enter a new value.
*/

/* PARAMETERS */

	dcl     gnc_old_copies                char (*);    /* input */
	dcl     gnc_new_copies                char (*) var;/* output */
	dcl     gnc_new_copies_bin            fixed bin;   /* output binary*/

/* BEGIN */

	gnc_new_copies = "";
	gnc_new_copies_bin = 0;

	call ioa_ ("The number of copies requested is: ^a", gnc_old_copies);

	call ioa_ ("You may now reset the number of copies, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");

	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("Number of copies (1 - 30):  ", "", REVIEW_DEFAULTS_HELP, COPIES_QUESTION, gnc_new_copies);
	     if length (gnc_new_copies) = 0
	     then valid = "1"b;
	     else if gnc_new_copies = LIST
	     then call ioa_ ("The number of copies requested is: ^a", gnc_old_copies);
	     else if verify (gnc_new_copies, NUMERICS) ^= 0
	     then call ioa_ (COPIES_NO_GOOD);

	     else do;                                     /* convert to binary and check against limit */
		call CONVERT (gnc_new_copies, gnc_new_copies_bin, status);
		if status = 0
		then if gnc_new_copies_bin < 1 | gnc_new_copies_bin > COPIES_LIMIT
	               then call ioa_ (COPIES_NO_GOOD);
	               else valid = "1"b;                      /* valid number */
		else call ioa_ (COPIES_NO_GOOD);
	     end;
	end;

          return;

left_margin: entry (lm_option_name);

/* PARAMETERS */

	dcl     lm_option_name                 char (*);  /* input option name */

/* BEGIN */

	user_lmargin = "";

	call xmail_print_$get_left_margin (user_lmargin, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", lm_option_name);
	     go to left_margin_exit;
	end;

          call xmail_Review_Defaults_$get_new_margin (user_lmargin, response, response_bin);

	if length (response) = 0 | response = user_lmargin
	then call ioa_ ("^a remains unchanged.", lm_option_name);
	else do;
	     user_lmargin = response;
	     call xmail_print_$set_left_margin (user_lmargin, status);
	     if status = 0
	     then call ioa_ ("The left margin has been changed to: ^a spaces", user_lmargin);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", lm_option_name);
	end;

left_margin_exit: return;

get_new_margin: entry (gnm_old_lmargin, gnm_new_lmargin, gnm_new_lmargin_bin);

/*
     This entrypoint is called by both xmail_print_ and xmail_Review_Defaults_
     to allow the user to enter a new value.
*/

/* PARAMETERS */

	dcl     gnm_old_lmargin               char (*);    /* input */
	dcl     gnm_new_lmargin               char (*) var;/* output */
	dcl     gnm_new_lmargin_bin           fixed bin;   /* output binary*/

/* BEGIN */

	gnm_new_lmargin = "";
	gnm_new_lmargin_bin = 0;

	call ioa_ ("The left margin is: ^a spaces.", gnm_old_lmargin);

	call ioa_ ("You may now reset the left margin, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");
	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("Left margin (0 - 20):  ", "", REVIEW_DEFAULTS_HELP, LEFT_MARGIN_QUESTION, gnm_new_lmargin);
	     if length (gnm_new_lmargin) = 0
	     then valid = "1"b;
	     else if gnm_new_lmargin = LIST
	     then call ioa_ ("The left margin is: ^a spaces.", gnm_old_lmargin);
	     else if verify (gnm_new_lmargin, NUMERICS) ^= 0
	     then call ioa_ (MARGIN_NO_GOOD);

	     else do;                                     /* convert to binary and check against limit */
		call CONVERT (gnm_new_lmargin, gnm_new_lmargin_bin, status);
		if status = 0
		then if gnm_new_lmargin_bin > MARGIN_LIMIT
	               then call ioa_ (MARGIN_NO_GOOD);
	               else valid = "1"b;
		else call ioa_ (MARGIN_NO_GOOD);
	     end;
	end;

          return;

confirm_print: entry (cp_option_name);

/* PARAMETERS */

	dcl     cp_option_name                 char (*);  /* input option name */

/* BEGIN confirm_print */

	value_name = rtrim (CONFIRM_PRINT_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), cp_option_name, CONFIRM_PRINT_YN, "0"b);
	if changed_value
	then do;
	     if response = YES
	     then xmail_data.confirm_print = "1"b;
	     else xmail_data.confirm_print = "0"b;

	     call ioa_ ("The print options will ^[be displayed before printing to allow for changes.^;not be displayed.^]", response = YES);
	end;

	return;
	

/*
     The following are the entrypoints called to change the Outgoing Message
     options in the personalization menu.
*/

acknowledge: entry (a_option_name);

/* PARAMETERS */

	dcl     a_option_name                 char (*);   /* input option name */

/* BEGIN */

	value_name = rtrim (ACKNOWLEDGE_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), a_option_name, ACKNOWLEDGE_YN, "1"b);
	if changed_value
	then call ioa_ ("^[All messages will now^;^[Messages will not^;You will always be asked if you want to^]^] request an acknowledgment.", response = YES, response = NO);

          return;
	

save_messages: entry (smg_option_name);

/* PARAMETERS */

	dcl     smg_option_name                char (*);  /* input option name */

/* BEGIN */

	value_name = rtrim (SAVE_MESSAGE_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), smg_option_name, SAVE_MESSAGE_YN, "1"b);
	if changed_value
          then call ioa_ ("^[All outgoing messages will be saved.^;^[Outgoing messages will not be saved.^;You will always be asked if you want to save outgoing messages.^]^]", response = YES, response = NO);

          return;

msgs_as_mail: entry (mam_option_name);

/* PARAMETERS */

	dcl     mam_option_name                char (*);  /* input option name */

/* BEGIN */

	value_name = rtrim (MSGS_AS_MAIL_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), mam_option_name, MSGS_AS_MAIL_YN, "1"b);
	if changed_value
          then call ioa_ ("^[Interactive messages will be treated as mail.^;^[Interactive messages will not be treated as mail.^;You will always be asked if you want to treat interactive messages as mail.^]^]", response = YES, response = NO);

          return;

save_mailbox: entry (smb_option_name);

/* PARAMETERS */

	dcl     smb_option_name               char (*);   /* input option name */

/* BEGIN */

	value_name = rtrim (SAVE_MAILBOX_HELP);		/* use info constant */

	call xmail_value_$get ((value_name), save_mailbox, status);
	if status ^= 0
	then do;
	     call xmail_error_$no_code (status, NAME, "l", "An error has occurred that prevents access to ^a.", smb_option_name);
	     go to savebox_exit;
	end;

	save_mailbox = minus_suffix ((save_mailbox), (MAILFILE_SUFFIX));
	call ioa_ ("Outgoing savefile currently set to: ^a", save_mailbox);
	call ioa_ ("^/Type ""set"" to change the outgoing savefile," ||
	     "^/""ask"" to be asked for the savefile name each time" ||
	     "^/     a message is saved," ||
	     "^/or just press the RETURN key to leave it unchanged.^/");

	valid = "0"b;
	call ioa_$rsnnl ("How do you want to specify the outgoing savefile?:  ",
	     prompt_string, unused_return_length);
	do while (^valid);
	     call xmail_get_str_ (prompt_string, "", REVIEW_DEFAULTS_HELP, SAVE_MAILBOX_HELP, response);

/* Translate to make response case insensitive */

	     response = translate (response, LOWERCASE_YN_ASK, UPPERCASE_YN_ASK);
	     if response = A then response = ASK;
	     if response = S then response = SET;
	     if length (response) = 0 | response = SET | response = ASK
	     then valid = "1"b;
	     else if response = LIST
	     then call ioa_ ("Outgoing savefile currently set to: ^a", save_mailbox);
	     else call ioa_ ("You may only enter ""set"" or ""ask"", followed by a RETURN. ^/  Enter ? if you need help.");
	end;					/* end of do */

	if length (response) = 0
	then call ioa_ ("^a remains unchanged.", smb_option_name);
	else if response = ASK then do;
	     call xmail_value_$set ((value_name), (response), save_mailbox, status);
	     if status = 0
	     then call ioa_ ("^[You will always be asked for the name of the savefile when^;The ""^a"" savefile will be used for^] saving messages.", response = ASK, save_mailbox);
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", smb_option_name);
	end;
	else if response = SET then do;
	     call xmail_select_file_ ("mail file", MAILFILE_SUFFIX, "outgoing", ACCEPT_OLD, ACCEPT_NEW, dir, prefix, create, exists, status);
	     if status ^= 0 then go to savebox_exit;	/* Diagnostic msg already issued by xmail_select_file_. */

	     yes_sw = "0"b;
	     if ^create & ^exists then do;
		call ioa_$rsnnl ("The specified mail file ""^a"" does not exist.^/  Do you wish to create it?  ", prompt_string, unused_return_length, prefix);
		call xmail_get_str_$yes_no (prompt_string, yes_sw);
	     end;

	     if create | yes_sw then do;
		call mlsys_utils_$create_savebox (dir, (prefix), code);
		if code ^= 0
	          then call xmail_error_$code_first (status, NAME, LOG, "An error has occurred which prevents changing ^a.", smb_option_name);
		else call ioa_ ("The mail file ""^a"" has been created.", prefix);
	     end;

	     if exists | create | yes_sw then do;
		call xmail_value_$set ((value_name), prefix || FULL_MAILFILE_SUFFIX, save_mailbox, status);
		if status = 0
		then call ioa_ ("Option has been changed to ^[ask for the name of the file before^;use the ""^a"" savefile for^] saving messages.", response = ASK, prefix);
	          else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", smb_option_name);
	     end;
	     else call ioa_ ("^a remains unchanged.", smb_option_name);
	end;

savebox_exit: return;

full_name: entry (fn_option_name);

/* PARAMETERS */

	dcl     fn_option_name                 char (*);  /* input option name */
          dcl     get_pdir_                      entry() returns(char(168));
	    

/* BEGIN */

	new_full_name = "";

	if xmail_data.value_seg_pathname = get_pdir_() then
	     call value_$get (null (), PERPROCESS, FULL_NAME, new_full_name, status);
	else
	     call value_$get (null (), PERMANENT, FULL_NAME, new_full_name, status);
	if status ^= 0
	then if status = error_table_$oldnamerr
	     then call ioa_ ("Your full name is not currently defined.");
	     else do;
	          call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents access to ^a.", fn_option_name);
	          go to full_name_exit;
	     end;

	else call ioa_ ("The full name which appears in the From field of outgoing mail is:" ||
		"^/  ^a", new_full_name);

	call ioa_ ("You may now enter your full name, " ||
	     "or just press the RETURN key^/" ||
	     "  to leave it unchanged.");

	valid = "0"b;
	do while (^valid);
	     call xmail_get_str_ ("Enter your full name (32 character limit): ", "", REVIEW_DEFAULTS_HELP, FULL_NAME_QUESTION, response);

	     if response = LIST
	     then call ioa_ ("^[Your full name is not currently defined.^;Your full name currently is: ^a^]", new_full_name = "", new_full_name);
	     else if length (response) > length (new_full_name)
	     then call xmail_display_help_ (REVIEW_DEFAULTS_HELP, LONG_NAME, (0));
	     else valid = "1"b;
	end;					/* end of do */

	if length (response) = 0 | response = new_full_name
	then call ioa_ ("^a remains unchanged.", fn_option_name);
	else do;
	     call value_$set (null (), PERMANENT, FULL_NAME, (response), new_full_name, status);
	     if status = 0
	     then do;
		call ioa_ ("Full Name has been changed to: ^a", response);
		call ioa_ ("This change takes effect the next time you login to the system.");
	     end;
	     else if status = error_table_$no_w_permission then do;
                   call value_$set (null (), PERPROCESS, FULL_NAME, (response), new_full_name, status);
	         if status = 0
	         then do;
		    call ioa_ ("Full Name has been changed to: ^a", response);
		    call ioa_ ("This change is in effect during this process.");
	              end;
	         else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", fn_option_name);
	         end;
	     else call xmail_error_$no_code (status, NAME, "l", "An error has occurred which prevents changing ^a.", fn_option_name);
	end;

full_name_exit: return;

include_original: entry (io_option_name);

/* PARAMETERS */

	dcl     io_option_name                char (*);   /* input option name */
	dcl     new_option_name               char (32) var;
	        

/* BEGIN include_original */

	value_name = rtrim (INCLUDE_ORIGINAL_YN);         /* use info constant */

	call CHECK_VALUE_YN ((value_name), io_option_name, INCLUDE_ORIGINAL_YN, "1"b);
	if changed_value
	then call ioa_ ("^[Original messages will be included in all^;^[Original messages will not be included in^;You will always be asked if you want to include originals in^]^] replies.", response = YES, response = NO);

	value_name = rtrim (ORIGINAL_UP_WINDOW_YN);

	call ioa_(" ");
	new_option_name = "Display Original in Upper Window";
	call CHECK_VALUE_YN ((value_name),(new_option_name),ORIGINAL_UP_WINDOW_YN, "0"b);
	if changed_value
	then call ioa_("^[The original will be displayed in^;The original will not be displayed in^] the upper window.",response = YES);

          return;

file_original: entry (fo_option_name);

/* PARAMETERS */

	dcl     fo_option_name                char (*);   /* input option name */

/* BEGIN file_original */

	value_name = rtrim (FILE_ORIGINAL_YN);         /* use info constant */

	call CHECK_VALUE_YN ((value_name), io_option_name, FILE_ORIGINAL_YN, "1"b);
	if changed_value
	then call ioa_ ("^[Originals will always be filed before replies.^;^[Originals will not be filed.^;You will always be asked if you want to file originals before replies.^]^]", response = YES, response = NO);

          return;

/* 
     The following are the entrypoints called to change the Processing options
     in the personalization menu.
*/

interactive_msgs: entry (im_option_name);

/* PARAMETERS */

	dcl     im_option_name                 char (*);  /* input option name */

/* BEGIN interactive_msgs */

	value_name = rtrim (INTERACTIVE_MSGS_YN);	/* use info constant */

	call CHECK_VALUE_YN ((value_name), im_option_name, INTERACTIVE_MSGS_YN, "0"b);
	if changed_value
          then do;
	     call ioa_ ("Interactive messages will ^[be^;not be^] processed.", response = YES);
	     if response = YES
	     then do;
		xmail_data.interactive_msgs = "1"b;
		call xmail_im_mgr_$defer_messages;
	     end;
	     else if xmail_data.interactive_msgs = "1"b
						/* changing from yes to no */
	     then do;
		xmail_data.interactive_msgs = "0"b;
		call xmail_im_mgr_$print_messages;
		call xmail_im_mgr_$restore_original;
	     end;
	end;

	return;

lists_as_menus: entry (lam_option_name);

/* PARAMETERS */

	dcl     lam_option_name               char (*);   /* input option name */

/* BEGIN lists_as_menus */

	value_name = rtrim (LISTS_AS_MENUS_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), lam_option_name, LISTS_AS_MENUS_YN, "0"b);
	if changed_value
          then do;
	     if response = YES
	     then xmail_data.lists_as_menus = "1"b;
	     else xmail_data.lists_as_menus = "0"b;
	     call ioa_ ("Lists will ^[be^;not be^] displayed as menus.", response = YES);
	end;

	return;

remove_menu: entry (rm_option_name);

/* PARAMETERS */

	dcl     rm_option_name                 char (*);  /* input option name */

/* BEGIN remove_menu */

	value_name = rtrim (REMOVE_MENUS_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), rm_option_name, REMOVE_MENUS_YN, "0"b);
	if changed_value
	then do;
	     if response = YES
	     then xmail_data.remove_menus = "1"b;
	     else xmail_data.remove_menus = "0"b;

	     call ioa_ ("During editing, the top menu will ^[be^;not be^] removed.", response = YES);
	end;

	return;

escape_keys: entry (ek_option_name);

/* PARAMETERS */

	dcl     ek_option_name                 char (*);  /* input option name */

/* BEGIN escape_keys */

	value_name = rtrim (ALWAYS_ESCAPE_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), ek_option_name, ALWAYS_ESCAPE_YN, "0"b);
	if changed_value
          then do;
	     call ioa_ ("^[Escape sequences will always be used in place of function keys.^;Function keys will be used when available.^]", response = YES);
     	     if response = YES
     	     then	call CHANGE_TO_DEFAULT_KEYS;
	     else	call TEST_AND_CHANGE_FUNCTION_KEYS;
	end;

	return;

multics_mode: entry (mm_option_name);

/* PARAMETERS */

	dcl     mm_option_name                char (*);   /* input option name */

/* BEGIN multics_mode */

	value_name = rtrim (MULTICS_MODE_YN);		/* use info constant */

	call CHECK_VALUE_YN ((value_name), mm_option_name, MULTICS_MODE_YN, "0"b);
	if changed_value
          then do;
	     if response = YES
	     then do;
		xmail_data.n_fkeys_used = EIGHT_FKEYS;
		xmail_data.multics_mode = "1"b;
		call ioa_ ("Multics commands will be allowed.");
	     end;
	     else do;
		xmail_data.n_fkeys_used = SEVEN_FKEYS;
		xmail_data.multics_mode = "0"b;
		call ioa_ ("Multics commands will not be allowed.");
	     end;
	     call xmail_value_$get (rtrim (ALWAYS_ESCAPE_YN), answer_yn, status);
	     if status = 0 & answer_yn = NO
	     then call TEST_AND_CHANGE_FUNCTION_KEYS;
	end;

	return;

    end xmail_Review_Defaults_;




		    xmail_Review_Mlist_.pl1         09/02/88  0759.6r w 09/02/88  0746.6       91656



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


xmail_Review_Mlist_: proc ();

/* Author unknown

   83-07-27 DJ Schimke: Changed the mailing list suffix to "mls" to conform 
   with the mail_system_ standard.  Note that xmail_dir_manager_$open will
   add names with ".mls" suffix to any mailing lists with the ".mlist" suffix.
   This is part of the conversion to the new mail_system_ interfaces using
   version 2 mailboxes.

   83-10-04  DJ Schimke: Changed OPT (4): of PERFORM_OPTION to call
   xmail_get_str_$yes_no rather than xmail_get_str_. Also added cleanup
   handler and cleaned up other problems uncovered by audit.

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-07-03  DJ Schimke: Modified to use a three-column menu format changing
   the calls to xmail_create_emnu_ to include a N_COLUMNS parameter.
*/

/* Automatic */

	dcl     prompt_string	 char (80) var;
	dcl     default_list	 char (24) var;
	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     dir		 char (168);
	dcl     list_display	 char (38) varying;
	dcl     file		 char (32) var;
	dcl     new_dir		 char (168);
	dcl     new_file		 char (32) var;
	dcl     redisplay_menu	 bit (1) aligned;
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;

/* Entries */

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     window_$bell	 entry (ptr, fixed bin (35));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
	dcl     xmail_delete_mlist_	 entry (char (*), char (*));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_display_mlist_	 entry (char (*), char (*));
	dcl     xmail_dprint_mlist_	 entry (char (*), char (*));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_create_mlist_	 entry (char (*), fixed bin (35));
	dcl     xmail_update_mlist_	 entry (char (*), char (*));

/* Internal Static */

	dcl     menup		 ptr init (null) int static;

/* Constants */

	dcl     ALLOW_NEW		 bit (1) aligned init ("1"b) static options (constant);
	dcl     ALLOW_OLD		 bit (1) aligned init ("1"b) static options (constant);
	dcl     DONT_ALLOW_NEW	 bit (1) aligned init ("0"b) static options (constant);
	dcl     DONT_ALLOW_OLD	 bit (1) aligned init ("0"b) static options (constant);
	dcl     MLIST_SUFFIX	 char (3) init ("mls") int static options (constant);
	dcl     NAME		 char (19) init ("xmail_Review_Mlist_") int static options (constant);
	dcl     N_COLUMNS		 fixed bin static options (constant) init (3);

	dcl     OPTION_NAMES	 static options (constant) init (
				 "Create",
				 "Display",
				 "Update",
				 "Discard",
				 "Rename",
				 "Print") dim (6) char (15) varying;

/* External Static */

	dcl     (xmail_err_$help_requested,
	        xmail_err_$exit_now,
	        error_table_$nomatch)	 fixed bin (35) ext static;

	dcl     iox_$user_output	 ptr ext;
	dcl     msg_to_user		 static options (constant) init
				 ("You have no mailing lists.") char (26);


	dcl     (cleanup, program_interrupt, quit, xmail_redisplay_menu) condition;

	dcl     (null, rtrim, sum, translate) builtin;

	star_names_ptr = null ();
	star_entry_ptr = null ();
	on condition (cleanup) call CLEAN_UP;

	on condition (xmail_redisplay_menu) begin;
		if menup ^= null
		then call menu_$display (xmail_windows.menu.iocb, menup, (0)); /* ignore errors, can't recover */
	     end;

	if menup = null then do;
	     call xmail_create_menu_ (" Mailing Lists ", OPTION_NAMES, N_COLUMNS, menup, code);
	     if code ^= 0 then call review_mlists_err (code, "While creating menu.");
	end;

	default_list = "";
	list_display = "";
	file = " ";

	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	on condition (program_interrupt) go to START;

	call window_$clear_window (iox_$user_output, (0));/* ignore errors, can't recover */
	call ioa_ (" ");

START:

	call hcs_$star_ ((xmail_data.mail_dir), "**." || MLIST_SUFFIX, 2, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, code);
	if code ^= 0 & code ^= error_table_$nomatch
	then call review_mlists_err (code, "While getting mailing list count.");
	redisplay_menu = "1"b;
	do while ("1"b);
	     call xmail_get_choice_ (menup, (list_display), "", "", xmail_data.normal_usage, redisplay_menu, "", choice, code);
	     redisplay_menu = "0"b;
	     if code = 0
	     then call PERFORM_OPTION (choice, redisplay_menu);
	     else if code = xmail_err_$help_requested
	     then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now
	     then go to EXIT;
	     else call window_$bell (iox_$user_output, (0));
	end;					/* do while */

EXIT:

	return;
%page;
PERFORM_OPTION: proc (P_opt, P_redisplay);

	dcl     P_opt		 fixed bin;
	dcl     P_redisplay		 bit (1) aligned;
	dcl     new_mlist_name	 char (24) varying;
	dcl     new_seg_prefix	 char (32) varying;
	dcl     seg_dir		 char (168);

	dcl     hcs_$chname_file	 entry (char (*), char (*), char (*), char (*),
				 fixed bin (35));
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     yes_sw		 bit (1) aligned;



	call window_$clear_window (iox_$user_output, (0));
	go to OPT (P_opt);


OPT (1):						/* Create option */

	new_mlist_name = "";
	call xmail_create_mlist_ ((new_mlist_name), code);
	if code = 0
	then do;
	     default_list = new_mlist_name;
	     star_entry_count = star_entry_count + 1;
	end;
	return;

OPT (2):						/* Display option */

	if star_entry_count = 0
	then do;
	     call ioa_ (msg_to_user);
	     return;
	end;

	call SELECT_NEW_FILE ("displayed", (default_list));

	call xmail_display_mlist_ (dir, file || "." || MLIST_SUFFIX);
	return;



OPT (3):						/* Update option */

	if star_entry_count = 0
	then do;
	     call ioa_ (msg_to_user);
	     return;
	end;

	call SELECT_NEW_FILE ("updated", (default_list));

	call xmail_update_mlist_ (dir, file || "." || MLIST_SUFFIX);
	return;

OPT (4):						/* Discard option */

	if star_entry_count = 0
	then do;
	     call ioa_ (msg_to_user);
	     return;
	end;
	call SELECT_NEW_FILE ("discarded", (default_list));

	call ioa_$rsnnl ("Do you want to discard mailing list ""^a"" ? ", prompt_string, (0), file, code);
	call xmail_get_str_$yes_no (prompt_string, yes_sw);
	if yes_sw then do;
	     call xmail_delete_mlist_ (dir, file || "." || MLIST_SUFFIX);
	     default_list = "";
	     star_entry_count = star_entry_count - 1;
	     if star_entry_count = 0 then call ioa_ ("You have no mail list.");
	end;
	return;

OPT (5):						/* Rename option */

	if star_entry_count = 0
	then do;
	     call ioa_ (msg_to_user);
	     return;
	end;
	call SELECT_NEW_FILE ("renamed", (default_list));

	call ioa_$nnl ("Renaming ""^a"": ", file);
	call xmail_select_file_$caller_msg ("mailing list", MLIST_SUFFIX, "", DONT_ALLOW_OLD, ALLOW_NEW, seg_dir, new_seg_prefix, "New name", unused_bit, unused_bit2, code);
	if code ^= 0
	then do;
	     call ioa_ ("Selection of new mailing list name not successful.");
	     return;
	end;

	call hcs_$chname_file (rtrim (seg_dir), file || "." || MLIST_SUFFIX,
	     file || "." || MLIST_SUFFIX,
	     rtrim (new_seg_prefix) || "." || MLIST_SUFFIX, code);
	call ioa_ ("Mailing list name changed from ""^a"" to ""^a"".", file,
	     new_seg_prefix);
	file = new_seg_prefix;
	default_list = file;
	return;

OPT (6):						/* Print option */

	if star_entry_count = 0
	then do;
	     call ioa_ (msg_to_user);
	     return;
	end;
	call SELECT_NEW_FILE ("printed", (default_list));

	call xmail_dprint_mlist_ (dir, file || "." || MLIST_SUFFIX);
	return;

     end PERFORM_OPTION;

%page;
EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin;

	call window_$clear_window (iox_$user_output, (0));
	call xmail_display_help_ (NAME || ".gi.info",
	     translate (OPTION_NAMES (opt), "_", " "), code);
	if code ^= 0 then call review_mlists_err (code, "Unable to display help for this option.");

     end EXPLAIN_OPTION;

review_mlists_err: proc (P_code, P_str);

	dcl     P_code		 fixed bin (35);
	dcl     P_str		 char (*);

	call xmail_error_$no_code (code, NAME, "l", P_str);
	go to EXIT;

     end review_mlists_err;

SELECT_NEW_FILE: proc (P_text, P_default);

	dcl     P_text		 char (*) parameter;
	dcl     P_default		 char (*) parameter;

	dcl     message		 char (78) varying;

	message = "Enter name of list to be " || P_text || " ";

	call xmail_select_file_$caller_msg ("list", MLIST_SUFFIX, (P_default), ALLOW_OLD, DONT_ALLOW_NEW, new_dir, new_file, (message), unused_bit, unused_bit2, code);
	if code ^= 0 then return;
	dir = new_dir;
	file = new_file;
	default_list = file;
	return;

     end SELECT_NEW_FILE;

CLEAN_UP: proc;
	if star_names_ptr ^= null () then free star_names;/* order is important */
	if star_entry_ptr ^= null () then free star_entries;
     end CLEAN_UP;

%page;
%include menu_dcls;
%page;
%include star_structures;
%page;
%include xmail_windows;
%page;
%include xmail_data;
%page;

     end xmail_Review_Mlist_;




		    xmail_Review_Outgoing_.pl1      09/02/88  0759.6r w 09/02/88  0746.6       50157



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


/****^  HISTORY COMMENTS:
  1) change(86-03-05,Blair), approve(86-03-05,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Written by Joanne Backs from xmail_Review_Defaults_.pl1.
                                                   END HISTORY COMMENTS */

xmail_Review_Outgoing_: proc;

/* BEGIN DESCRIPTION

function:	This procedure provides the xmail user with a menu for the
	purpose of inspecting and updating default values which control
	outgoing messages during the operation of xmail.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     choice                 fixed bin;
	dcl     code                   fixed bin (35);
	dcl     display_needed         bit (1) aligned;

/* CONSTANTS */

	dcl     NAME                   init ("xmail_Review_Outgoing_") char (22) int static options (constant);
	dcl     N_COLUMNS              fixed bin int static options (constant) init (2);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "Message Acknowledgment",
				 "Save Outgoing Messages",
			           "Set Outgoing Savefile",
			           "Set Full Name",
			           "Include Original in Reply",
			           "File Original Before Reply"
				 ) dim (6) char (28) var;
	dcl     TITLE		 init ("Personalize Outgoing Message Options") char (36)
				 int static options (constant);

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr ext static;
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);

/* INTERNAL STATIC */

	dcl     menu		 int static ptr init (null);

/* ENTRIES */

	dcl     ioa_		 entry options (variable);
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_Review_Defaults_$acknowledge entry (char (*));
	dcl     xmail_Review_Defaults_$file_original entry (char (*));
	dcl     xmail_Review_Defaults_$full_name entry (char (*));
	dcl     xmail_Review_Defaults_$include_original entry (char (*));
	dcl     xmail_Review_Defaults_$save_mailbox entry (char (*));
	dcl     xmail_Review_Defaults_$save_messages entry (char (*));
	dcl     xmail_window_manager_$reconnect entry options (variable);

/* CONDITIONS */

	dcl     (program_interrupt, xmail_redisplay_menu, quit) condition;

/* BUILTINS */

	dcl     (null, translate) builtin;

/* INCLUDE FILES */

%include menu_dcls;
%page;
%include xmail_data;
%page;
%include xmail_help_infos;
%page;
%include xmail_windows;
%page;
%include window_dcls;

/* BEGIN */
	on condition (xmail_redisplay_menu) begin;
		if menu ^= null
		then call menu_$display (xmail_windows.menu.iocb, menu, (0));
	     end;

	if menu = null then do;
	     call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menu, code);
	     if code ^= 0 then call xmail_error_$no_code (status, NAME, "q",
		     "A programming error has been detected which prevents " ||
		     "the use of the ^a menu.", TITLE);

	end;

	on condition (program_interrupt) go to START;
	on condition (quit) begin;
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	call window_$clear_window (iox_$user_output, (0));
	call ioa_ (" ");

START:	display_needed = "1"b;
	do while ("1"b);
	     call xmail_get_choice_ (menu, "", "", "", xmail_data.normal_usage,
		display_needed, "", choice, code);
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now then go to EXIT;
	     else call window_$bell (iox_$user_output, (0));
	end;
EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* PARAMETERS */

	dcl     redisplay		 bit (1) aligned parameter;
	dcl     opt		 fixed bin parameter;

/* AUTOMATIC */

	 dcl    name                   char (28) varying; /* name of option*/

/* BEGIN PERFORM_OPTION */

	call window_$clear_window (iox_$user_output, (0));
	name = OPTION_NAMES (opt);                        /* include name of option */
	go to OPT (opt);

OPT (1):	redisplay = "0"b;
	call xmail_Review_Defaults_$acknowledge ((name));
	go to OPT_EXIT;

OPT (2):	redisplay = "0"b;
	call xmail_Review_Defaults_$save_messages ((name));
	go to OPT_EXIT;

OPT (3):	redisplay = "0"b;
	call xmail_Review_Defaults_$save_mailbox ((name));
	go to OPT_EXIT;

OPT (4):	redisplay = "0"b;
	call xmail_Review_Defaults_$full_name ((name));
	go to OPT_EXIT;

OPT (5):	redisplay = "0"b;
	call xmail_Review_Defaults_$include_original ((name));
	go to OPT_EXIT;

OPT (6):	redisplay = "0"b;
	call xmail_Review_Defaults_$file_original ((name));
	go to OPT_EXIT;

OPT_EXIT: return;
     end PERFORM_OPTION;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin parameter;

	call window_$clear_window (iox_$user_output, (0));
	call xmail_display_help_ (REVIEW_DEFAULTS_HELP,
	     translate (OPTION_NAMES (opt), "_", " "),
	     (0));

     end EXPLAIN_OPTION;

  end xmail_Review_Outgoing_;




		    xmail_Review_Printing_.pl1      09/02/88  0759.6r w 09/02/88  0746.6       50805



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


/****^  HISTORY COMMENTS:
  1) change(86-03-05,Blair), approve(86-03-05,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Written by Joanne Backs from xmail_Review_Defaults_.pl1.
                                                   END HISTORY COMMENTS */

xmail_Review_Printing_: proc;

/* BEGIN DESCRIPTION

function:	This procedure provides the xmail user with a menu for the
	purpose of inspecting and updating default values which control
	printing during the operation of xmail.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     choice                 fixed bin;
	dcl     code                   fixed bin (35);
	dcl     display_needed         bit (1) aligned;

/* CONSTANTS */

	dcl     NAME                   init ("xmail_Review_Printing_") char (22) int static options (constant);
	dcl     N_COLUMNS              fixed bin int static options (constant) init (2);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "Set Header",
				 "Set Destination",
			           "Set Station",
			           "Set Left Margin",
			           "Set Number of Copies",
			           "Notify After Printing",
			           "Confirm Print Options"
				 ) dim (7) char (28) var;
	dcl     TITLE		 init ("Personalize Printing Options") char (28)
				 int static options (constant);

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr ext static;
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);

/* INTERNAL STATIC */

	dcl     menu		 int static ptr init (null);

/* ENTRIES */

	dcl     ioa_		 entry options (variable);
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_Review_Defaults_$confirm_print entry (char (*));
	dcl     xmail_Review_Defaults_$copies entry (char (*));
	dcl     xmail_Review_Defaults_$destination entry (char (*));
	dcl     xmail_Review_Defaults_$header entry (char (*));
	dcl     xmail_Review_Defaults_$left_margin entry (char (*));
	dcl     xmail_Review_Defaults_$notify entry (char (*));
	dcl     xmail_Review_Defaults_$station entry (char (*));
	dcl     xmail_window_manager_$reconnect entry options (variable);

/* CONDITIONS */

	dcl     (program_interrupt, xmail_redisplay_menu, quit) condition;

/* BUILTINS */

	dcl     (null, translate) builtin;

/* INCLUDE FILES */

%include menu_dcls;
%page;
%include xmail_data;
%page;
%include xmail_help_infos;
%page;
%include xmail_windows;
%page;
%include window_dcls;

/* BEGIN */
	on condition (xmail_redisplay_menu) begin;
		if menu ^= null
		then call menu_$display (xmail_windows.menu.iocb, menu, (0));
	     end;

	if menu = null then do;
	     call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menu, code);
	     if code ^= 0 then call xmail_error_$no_code (status, NAME, "q",
		     "A programming error has been detected which prevents " ||
		     "the use of the ^a menu.", TITLE);

	end;

	on condition (program_interrupt) go to START;
	on condition (quit) begin;
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	call window_$clear_window (iox_$user_output, (0));
	call ioa_ (" ");

START:	display_needed = "1"b;
	do while ("1"b);
	     call xmail_get_choice_ (menu, "", "", "", xmail_data.normal_usage,
		display_needed, "", choice, code);
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now then go to EXIT;
	     else call window_$bell (iox_$user_output, (0));
	end;
EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* PARAMETERS */

	dcl     redisplay		 bit (1) aligned parameter;
	dcl     opt		 fixed bin parameter;

/* AUTOMATIC */

	 dcl    name                   char (28) varying;

/* BEGIN PERFORM_OPTION */

	call window_$clear_window (iox_$user_output, (0));
	name = OPTION_NAMES (opt);                        /* include name of option*/
	go to OPT (opt);

OPT (1):	redisplay = "0"b;
	call xmail_Review_Defaults_$header ((name));
	go to OPT_EXIT;

OPT (2):	redisplay = "0"b;
	call xmail_Review_Defaults_$destination ((name));
	go to OPT_EXIT;

OPT (3):	redisplay = "0"b;
	call xmail_Review_Defaults_$station ((name));
	go to OPT_EXIT;

OPT (4):	redisplay = "0"b;
	call xmail_Review_Defaults_$left_margin ((name));
	go to OPT_EXIT;

OPT (5):	redisplay = "0"b;
	call xmail_Review_Defaults_$copies ((name));
	go to OPT_EXIT;

OPT (6):	redisplay = "0"b;
	call xmail_Review_Defaults_$notify ((name));
	go to OPT_EXIT;

OPT (7):	redisplay = "0"b;
	call xmail_Review_Defaults_$confirm_print ((name));
	go to OPT_EXIT;

OPT_EXIT: return;
     end PERFORM_OPTION;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin parameter;

	call window_$clear_window (iox_$user_output, (0));
	call xmail_display_help_ (REVIEW_DEFAULTS_HELP,
	     translate (OPTION_NAMES (opt), "_", " "),
	     (0));

     end EXPLAIN_OPTION;

  end xmail_Review_Printing_;




		    xmail_Review_Processing_.pl1    09/02/88  0759.6r w 09/02/88  0746.6       52110



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


/****^  HISTORY COMMENTS:
  1) change(86-03-05,Blair), approve(86-03-05,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Written by Joanne Backs from xmail_Review_Defaults_.pl1.
  2) change(87-01-16,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Add a new option for including interactive messages in the mailbox.
                                                   END HISTORY COMMENTS */

xmail_Review_Processing_: proc;

/* BEGIN DESCRIPTION

function:	This procedure provides the xmail user with a menu for the
	purpose of inspecting and updating default values which control
	processing aspects during the operation of xmail.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     choice                 fixed bin;
	dcl     code                   fixed bin (35);
	dcl     display_needed         bit (1) aligned;

/* CONSTANTS */

	dcl     NAME                   init ("xmail_Review_Processing_") char (24) int static options (constant);
	dcl     N_COLUMNS              fixed bin int static options (constant) init (2);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "Process Interactive Messages",
				 "Display Lists As Menus",
			           "Remove Menu While Editing",
			           "Always Use Escape Sequences",
			           "Multics Command Mode",
		                     "Include Interactive Messages"
				 ) dim (6) char (28) var;
	dcl     TITLE		 init ("Personalize Processing Options") char (30)
				 int static options (constant);

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr ext static;
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);

/* INTERNAL STATIC */

	dcl     menu		 int static ptr init (null);

/* ENTRIES */

	dcl     ioa_		 entry options (variable);
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var, fixed bin, ptr, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_Review_Defaults_$escape_keys entry (char (*));
	dcl     xmail_Review_Defaults_$interactive_msgs entry (char (*));
	dcl     xmail_Review_Defaults_$lists_as_menus entry (char (*));
          dcl     xmail_Review_Defaults_$msgs_as_mail entry (char (*));
	dcl     xmail_Review_Defaults_$multics_mode entry (char (*));
	dcl     xmail_Review_Defaults_$remove_menu entry (char (*));
	dcl     xmail_window_manager_$reconnect entry options (variable);

/* CONDITIONS */

	dcl     (program_interrupt, xmail_redisplay_menu, quit) condition;

/* BUILTINS */

	dcl     (null, translate) builtin;

/* INCLUDE FILES */

%include menu_dcls;
%page;
%include xmail_data;
%page;
%include xmail_help_infos;
%page;
%include xmail_windows;
%page;
%include window_dcls;

/* BEGIN */
	on condition (xmail_redisplay_menu) begin;
		if menu ^= null
		then call menu_$display (xmail_windows.menu.iocb, menu, (0));
	     end;

	if menu = null then do;
	     call xmail_create_menu_ (TITLE, OPTION_NAMES, N_COLUMNS, menu, code);
	     if code ^= 0 then call xmail_error_$no_code (status, NAME, "q",
		     "A programming error has been detected which prevents " ||
		     "the use of the ^a menu.", TITLE);

	end;

	on condition (program_interrupt) go to START;
	on condition (quit) begin;
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;

	call window_$clear_window (iox_$user_output, (0));
	call ioa_ (" ");

START:	display_needed = "1"b;
	do while ("1"b);
	     call xmail_get_choice_ (menu, "", "", "", xmail_data.normal_usage,
		display_needed, "", choice, code);
	     display_needed = "0"b;
	     if code = 0 then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);
	     else if code = xmail_err_$exit_now then go to EXIT;
	     else call window_$bell (iox_$user_output, (0));
	end;
EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* PARAMETERS */

	dcl     redisplay		 bit (1) aligned parameter;
	dcl     opt		 fixed bin parameter;

/* AUTOMATIC */

	 dcl    name                   char (28) varying;

/* BEGIN PERFORM_OPTION */

	call window_$clear_window (iox_$user_output, (0));
	name = OPTION_NAMES (opt);                        /* include name of option*/
	go to OPT (opt);

OPT (1):	redisplay = "0"b;
	call xmail_Review_Defaults_$interactive_msgs ((name));
	go to OPT_EXIT;

OPT (2):	redisplay = "0"b;
	call xmail_Review_Defaults_$lists_as_menus ((name));
	go to OPT_EXIT;

OPT (3):	redisplay = "0"b;
	call xmail_Review_Defaults_$remove_menu ((name)); 
	go to OPT_EXIT;

OPT (4):	redisplay = "0"b;
	call xmail_Review_Defaults_$escape_keys ((name)); 
	go to OPT_EXIT;

OPT (5):	redisplay = "0"b;
	call xmail_Review_Defaults_$multics_mode ((name));
	go to OPT_EXIT;

OPT (6):	redisplay = "0"b;
	call xmail_Review_Defaults_$msgs_as_mail ((name));
	go to OPT_EXIT;
	
OPT_EXIT: return;
     end PERFORM_OPTION;

EXPLAIN_OPTION: proc (opt);

	dcl     opt		 fixed bin parameter;

	call window_$clear_window (iox_$user_output, (0));
	call xmail_display_help_ (REVIEW_DEFAULTS_HELP,
	     translate (OPTION_NAMES (opt), "_", " "),
	     (0));

     end EXPLAIN_OPTION;

  end xmail_Review_Processing_;




		    xmail_Send_Mail_.pl1            09/02/88  0759.6r w 09/02/88  0746.6      126504



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



/****^  HISTORY COMMENTS:
  1) change(86-01-10,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Set switch to allow processing of your mail in other users' mailboxes when
     the option to Select Filed Mail is chosen.
  2) change(87-01-13,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Create a new option for printing deferred messages and update the prompt
     for deleting deferred messages to distinguish between deferred files and
     save files.  Error list entries 131, 132.
  3) change(87-01-19,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Determine whether we've been looking at all msgs or ordinary ones only
     before checking to see if we have any messages in the mailbox.
  4) change(87-08-10,Blair), approve(87-12-10,MCR7818),
     audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013):
     Initialize the reply-to field in the message header of a new
     message.
                                                   END HISTORY COMMENTS */


xmail_Send_Mail_: proc (what_next);

/* BEGIN DESCRIPTION

function:

history:     Written by P. Kizivat, format: style1

             Extensively modified by R. Ignagni 

   83-06-27  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-10-04  DJ Schimke: Added calls to xmail_get_str_$yes_no to handle all
   yes/no type questions. Restructured the code to remove coding standards
   violations and satisfy audit.

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-07-03  DJ Schimke: Modified to use a three-column menu format changing
   the calls to xmail_create_emnu_ to include a N_COLUMNS parameter.

   84-08-08  JG Backs: Modified for the addition of blind carbon copies (bcc).

   84-10-02  JG Backs: Modified the code at OPT (7) in PERFORM_OPTION proc to
   stay in Send Mail Menu if there are no messages in "incoming" mailbox.

   84-11-14  JG Backs: Deleted a call to window_$clear_window in the internal
   procedure CLEAN_UP, so there would be no screen output if cleanup condition.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     what_next		 char (9);

/* AUTOMATIC */

	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     display_needed	 bit (1) aligned;
	dcl     message_count, ordinary_message_count, total_message_count fixed bin;
	dcl     return_to_caller	 bit (1) aligned;
	dcl     sm_area_ptr		 ptr;
	dcl     yes_sw		 bit (1) aligned;
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;

/* BASED */

	dcl     send_mail_area	 area based (sm_area_ptr);

/* BUILTINS */

	dcl     (null, rtrim, translate) builtin;

/* CONDITIONS */

	dcl     (cleanup, program_interrupt, xmail_redisplay_menu, quit) condition;

/* CONSTANTS */

	dcl     ACCEPT_OLD		 init ("1"b) bit (1) aligned
				 int static options (constant);
	dcl     ALLOW_SELECTION	 init ("1"b) bit (1) aligned
				 int static options (constant);
	dcl     COUNT_BY_TYPE	 init ("1"b) bit (1) aligned
				 int static options (constant);
	dcl     DELETE_SEGMENT_FORCE	 init ("100100"b) bit (6)
				 int static options (constant);
	dcl     DELETE_SEGMENT_FORCE_CHASE
				 init ("100101"b) bit (6)
				 int static options (constant);
	dcl     DONT_ACCEPT_NEW	 init ("0"b) bit (1) aligned
				 int static options (constant);
	dcl     MENU_HEADING	 init ("Send Mail") char (9)
				 int static options (constant);
	dcl     NAME		 init ("xmail_Send_Mail_") char (16)
				 int static options (constant);
	dcl     N_COLUMNS		 init (3) fixed bin
				 int static options (constant);
	dcl     OPTION_NAMES	 int static options (constant) init (
				 "New Message",
				 "Deferred Message",
				 "File Sent Message",
				 "Print Sent Message",
	                               "Print Deferred Msg",
				 "Discard Deferred Msg",
				 "Mailing Lists",
				 "Process Incoming Mail",
				 "Process Filed Mail"
				 ) dim (9) char (30) varying;

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr external static;
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);

/* ENTRIES */

	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     mail_system_$free_message entry (ptr, fixed bin (35));
	dcl     mail_system_$free_address_list entry (ptr, fixed bin (35));
	dcl     mail_system_$get_message_counts entry (char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     xmail_create_menu_	 entry (char (*), (*) char (*) var,
				 fixed bin, ptr, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$no_code	 entry options (variable);
	dcl     xmail_get_choice_	 entry (ptr, char (*), char (*), char (*), char (*), bit (1) aligned, char (*), fixed bin, fixed bin (35));
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_window_manager_$reconnect entry ();

/* INTERNAL STATIC */

	dcl     menup		 int static ptr init (null);

/* INCLUDE FILES */

%include area_info;
%page;
%include menu_dcls;
%page;
%include xmail_help_infos;
%page;
%include xmail_send_mail;
%page;
%include xmail_windows;
%page;
%include xmail_data;
%page;
%include window_dcls;
%page;
%include star_structures;

/* BEGIN */

	on condition (xmail_redisplay_menu) begin;
		if menup ^= null ()
		then call menu_$display (xmail_windows.menu.iocb, menup, (0)); /* error ignored, no recovery */
	     end;

	if menup = null then do;
	     call xmail_create_menu_ (MENU_HEADING, OPTION_NAMES, N_COLUMNS, menup, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, "q", "A program error has occurred which prevents the use of the ^a menu.", MENU_HEADING);
	     if menup = null then go to EXIT;
	end;

	call window_$clear_window (iox_$user_output, (0));/* ignore error */

	sm_area_ptr = get_system_free_area_ ();

	send_mail_info_ptr = null ();
	on condition (cleanup) call CLEAN_UP;

	allocate send_mail_info in (send_mail_area) set (send_mail_info_ptr);

/* Initialize the message status  */

	send_mail_info.send_mail_area_ptr = sm_area_ptr;
	send_mail_info.msg_exists = "0"b;
	send_mail_info.emacs_seg_ptr = null ();
	send_mail_info.stored_seg_ptr = null ();
	send_mail_info.new_msg_ptr = null ();
          send_mail_info.reply_to_list_ptr = null ();
	send_mail_info.to_list_ptr = null ();
	send_mail_info.cc_list_ptr = null ();
	send_mail_info.bcc_list_ptr = null ();
	send_mail_info.emacs_seg_pathname = "";


	on condition (program_interrupt) goto START;
	on condition (quit)
	     begin;
		call xmail_window_manager_$reconnect ();
		go to START;
	     end;


START:

	display_needed = "1"b;
	return_to_caller = "0"b;
	do while ("1"b);
	     if return_to_caller then goto EXIT;
	     call xmail_get_choice_ (menup, "", "", "", xmail_data.normal_usage, display_needed, "", choice, code);
	     display_needed = "0"b;
	     if code = 0
	     then call PERFORM_OPTION (choice, display_needed);
	     else if code = xmail_err_$help_requested then call EXPLAIN_OPTION (choice);

	     else if code = xmail_err_$exit_now then go to EXIT;

	     else call window_$bell (xmail_windows.menu.iocb, (0)); /* ignore error */
	end;

EXIT:	return;

/* INTERNAL PROCEDURES */

PERFORM_OPTION: proc (opt, redisplay);

/* PARAMETERS */
	dcl     opt		 fixed bin;
	dcl     redisplay		 bit (1) aligned;

/* AUTOMATIC */

	dcl     prompt_string	 char (80) var;
	dcl     star_entry_count	 fixed bin;
	dcl     defer_dir		 char (168);
	dcl     defer_file		 char (32) var;

/* ENTRIES */

	dcl     xmail_Consult_Files_	 entry ();
	dcl     xmail_Review_Mlist_	 entry ();
          dcl     xmail_dprint_mlist_ entry (char(*), char(*));
	dcl     xmail_file_msgs_$single_msg entry (ptr, char (32) var, bit (1) aligned);
	dcl     xmail_prepare_msg_	 entry (bit (1));
	dcl     xmail_send_mail_print_msg_ entry ();
	dcl     xmail_send_stored_msg_ entry ();
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));

/* BEGIN */

	call window_$clear_window (iox_$user_output, (0));
	go to OPT (opt);

OPT (1):	redisplay = "0"b;
	call xmail_prepare_msg_ ("0"b);
	go to OPT_EXIT;

OPT (2):	redisplay = "0"b;
	call xmail_send_stored_msg_ ();
	go to OPT_EXIT;

OPT (3):	redisplay = "0"b;
	if send_mail_info.msg_exists
	then call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, "", ALLOW_SELECTION);
	else call ioa_ ("There is no message to file.");
	go to OPT_EXIT;

OPT (4):	redisplay = "0"b;
	call xmail_send_mail_print_msg_ ();
	go to OPT_EXIT;

OPT (5):	redisplay = "0"b;

	call xmail_select_file_$caller_msg ("deferred message", "defer", "", ACCEPT_OLD, DONT_ACCEPT_NEW, defer_dir, defer_file, "Enter name of ""deferred"" message to be printed (or ?? for list)", unused_bit, unused_bit2, code);
	if code ^= 0 then goto OPT_EXIT;
	call xmail_dprint_mlist_ (defer_dir, rtrim(defer_file) || "." || "defer");
	goto OPT_EXIT;

OPT (6):	redisplay = "0"b;
	call xmail_select_file_$caller_msg ("deferred message", "defer", "", ACCEPT_OLD, DONT_ACCEPT_NEW, defer_dir, defer_file, "Enter name of ""deferred"" message to be discarded (or ?? for list)", unused_bit, unused_bit2, code);
	if code ^= 0 then go to OPT_EXIT;
	call ioa_$rsnnl ("Do you wish to discard the deferred message ""^a""? ", prompt_string, (0), defer_file, code);
	call xmail_get_str_$yes_no (prompt_string, yes_sw);
	if yes_sw then do;
	     call delete_$path (defer_dir, rtrim (defer_file) || ".defer", DELETE_SEGMENT_FORCE, NAME, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, "q", "Sorry, the ""deferred"" message not discarded. An internal error.");
	     call ioa_ ("Deferred message ""^a"" discarded.", defer_file);
	end;
	go to OPT_EXIT;

OPT (7):	redisplay = "1"b;
	call xmail_Review_Mlist_ ();
	go to OPT_EXIT;

OPT (8):
	xmail_data.mail_in_incoming = "1"b;
	call mail_system_$get_message_counts ((mail_dir), "incoming", COUNT_BY_TYPE, total_message_count, ordinary_message_count, (0), code);
	if xmail_data.msgs_as_mail then
	     message_count = total_message_count;
	     else message_count = ordinary_message_count;
	if message_count = 0
	then do;					/* mailbox is empty */

	     xmail_data.mail_in_incoming = "0"b;
	     call iox_$control (iox_$user_output, "reset_more", null, (0));
	     call ioa_ ("There are no messages in your ""incoming"" mailbox.");
	     call hcs_$star_ ((xmail_data.mail_dir), "*.mbx", star_ALL_ENTRIES, null (),
		star_entry_count, (null ()), (null ()), (0)); /* ignore code since star_entry_count tells us want we need to know */

	     if star_entry_count > 1
	     then do;				/* may want another incoming mailbox */
		call xmail_get_str_$yes_no ("Still wish to go to ""Process Incoming Mail""?", yes_sw);
		if ^yes_sw then go to OPT_EXIT;
	     end;
	     else go to OPT_EXIT;			/* stay in Send Mail Menu */

	end;
	call window_$clear_window (iox_$user_output, (0));
	what_next = "proc_mail";
	return_to_caller = "1"b;
	go to OPT_EXIT;

OPT (9):	redisplay = "1"b;
	xmail_data.foreign_mailbox = "1"b;
	call xmail_Consult_Files_ ();
	xmail_data.foreign_mailbox = "0"b;
	go to OPT_EXIT;

OPT_EXIT:
	return;
     end PERFORM_OPTION;

EXPLAIN_OPTION: proc (opt);

/* PARAMETERS */

	dcl     opt		 fixed bin;

/* BEGIN */

	call window_$clear_window (iox_$user_output, (0));
	call xmail_display_help_ (NAME || ".gi.info", translate (OPTION_NAMES (opt), "_", " "), (0));

     end EXPLAIN_OPTION;

CLEAN_UP: proc ();

	if send_mail_info_ptr ^= null
	then do;
	     if send_mail_info.emacs_seg_ptr ^= null ()
	     then do;
		call delete_$ptr (send_mail_info.emacs_seg_ptr, DELETE_SEGMENT_FORCE_CHASE, NAME, code);
		send_mail_info.emacs_seg_ptr = null ();
	     end;

	     if send_mail_info.new_msg_ptr ^= null ()
	     then do;
		call mail_system_$free_message (send_mail_info.new_msg_ptr, code);
		send_mail_info.new_msg_ptr = null ();
	     end;

	     if send_mail_info.to_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.to_list_ptr, code);
		send_mail_info.to_list_ptr = null ();
	     end;

	     if send_mail_info.reply_to_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.reply_to_list_ptr, code);
		send_mail_info.reply_to_list_ptr = null ();
	     end;

	     if send_mail_info.cc_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.cc_list_ptr, code);
		send_mail_info.cc_list_ptr = null ();
	     end;

/* Add for bcc */

	     if send_mail_info.bcc_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.bcc_list_ptr, code);
		send_mail_info.bcc_list_ptr = null ();
	     end;

	end;

	return;
     end CLEAN_UP;

     end xmail_Send_Mail_;




		    xmail_area_.pl1                 11/15/83  1511.9r w 11/15/83  1400.2       13806



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


xmail_area_: proc ();

/* Parameter */

	dcl     P_area_ptr		 ptr;
	dcl     P_code		 fixed bin (35);

/* Automatic */

	dcl     1 area_def		 aligned like area_info;

/* Entries */

	dcl     define_area_	 entry (ptr, fixed bin (35));
	dcl     release_area_	 entry (ptr);

/* Static */

	dcl     sys_info$max_seg_size	 fixed bin (19) ext static;
	dcl     NAME		 char (11) init ("xmail_area_") int static options (constant);

/* Builtin */

	dcl     (addr, null, string)	 builtin;

create: entry (P_area_ptr, P_code);

	P_area_ptr = null;
	P_code = 0;

	area_def.version = area_info_version_1;
	string (area_def.control) = ""b;
	area_def.control.extend = "1"b;
	area_def.owner = NAME;
	area_def.size = sys_info$max_seg_size;
	area_def.areap = null;

	call define_area_ (addr (area_def), P_code);
	if P_code ^= 0 then return;

	P_area_ptr = area_def.areap;

	return;					/* create */

release: entry (P_area_ptr);

	call release_area_ (P_area_ptr);

	return;					/* release */


%page;
%include area_info;

     end xmail_area_;




		    xmail_create_menu_.pl1          12/02/84  1109.7rew 12/02/84  1015.0       27315



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


/*
			xmail_create_menu_

	This procedure creates the "static" menus displayed in the menu
	window.  It takes care of the details of header and trailer
	construction and the info structures needed by the menu_$create_menu
	procedure, both simplifying the interface for the callers and
	enforcing some consistency among menus.
*/

/*
   81-06-29 Paul Kyzivat: Original coding.

   81-07-31 Paul Kyzivat: Modified to drop _menu suffix from menu_ calls 

   84-07-03 Dave Schimke: Modified to add column_count parameter so xmail can
   use some menus with 3 columns as well as the  2 column format.
/*

/* format: style1 */
xmail_create_menu_: proc (title, choices, column_count, menu, code);

/* Parameter */

	dcl     title		 char (*),
	        choices		 (*) char (*) varying,
	        menu		 ptr,
	        column_count	 fixed bin,
	        code		 fixed bin (35);

/* Automatic */

	dcl     header		 (1) char (length (title) + 2) varying,
	        trailer		 (1) char (1) varying;

	dcl     1 actual_menu_requirements aligned like menu_requirements,
	        1 actual_menu_format	 aligned like menu_format;

/* Builtin */

	dcl     (addr, length, ltrim, rtrim) builtin;

/* Constant */

	dcl     OPTION_CODES	 (35) char (1) unal static options (constant) init
				 ("1", "2", "3", "4", "5", "6", "7", "8", "9",
				 "a", "b", "c", "d", "e", "f", "g", "h", "i",
				 "j", "k", "l", "m", "n", "o", "p", "q", "r",
				 "s", "t", "u", "v", "w", "x", "y", "z");

	dcl     PAD_CHAR		 init ("-") char (1) static options (constant);

/* Entry */

	dcl     get_system_free_area_	 entry () returns (ptr);
%page;

	header (1) = " ";
	header (1) = header (1) || rtrim (ltrim (title));
	header (1) = header (1) || " ";

	trailer (1) = PAD_CHAR;

	actual_menu_format.version = menu_format_version_1;
	actual_menu_format.max_width = xmail_windows.menu.width;
	actual_menu_format.max_height = xmail_windows.menu.height
	     + xmail_windows.bottom.height - 2;
	actual_menu_format.n_columns = column_count;
	actual_menu_format.center_headers = "1"b;
	actual_menu_format.center_trailers = "1"b;
	actual_menu_format.pad = "0"b;
	actual_menu_format.pad_char = PAD_CHAR;

	actual_menu_requirements.version = menu_requirements_version_1;

	call menu_$create (
	     choices,
	     header,
	     trailer,
	     addr (actual_menu_format),
	     OPTION_CODES,
	     get_system_free_area_ (),
	     addr (actual_menu_requirements),
	     menu,
	     code);
	return;
%page;
%include xmail_windows;
%page;
%include menu_dcls;

     end xmail_create_menu_;




		    xmail_create_mlist_.pl1         09/02/88  0759.6r w 09/02/88  0746.6       57249



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

xmail_create_mlist_: proc (mlist_name, status);

/* BEGIN DESCRIPTION

History:          Authur unknown

   83-10-17 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a 
   call to xmail_window_manager_$quit_handler so the quit condition handler
   can special-case the reconnect condition which should NOT interrupt 
   processing after the quit. phx 13227 This entrypoint also prompts when not
   at a reconnect condition so that unintentionally hitting the BREAK won't
   throw away any pending work. phx 13018

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-09-24 JG Backs: Added code before and after the call to emacs_ to test
   if menus should be removed before editing (personalization option Remove
   Menus While Editing).  If option is in effect, calls to new entrypoints,
   $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also
   added test in quit handler to make sure restore menus is done if quit in
   editor.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     mlist_name		 char (*) parameter;
	dcl     status		 fixed bin (35);

/* AUTOMATIC */

	dcl     code		 fixed bin (35);
	dcl     restore_menu_needed	 bit (1) aligned;	/* if remove menu */
	dcl     seg_dir		 char (168);
	dcl     seg_prefix		 char (32) var;
	dcl     seg_pname		 char (168);
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;

/* INTERNAL STATIC */

	dcl     ext_dir		 char (168) int static;
	dcl     ext_file		 char (32) int static;
	dcl     ext_pname		 char (168) int static;
	dcl     ext_ptr		 ptr init (null) int static;

/* ENTRIES */

	dcl     com_err_$suppress_name entry () options (variable);
	dcl     emacs_		 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$append_branch	 entry (char (*), char (*), fixed bin (5), fixed bin (35));
	dcl     hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     xmail_redisplay_$menu	 entry ();
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_window_manager_$restore_menu entry ();
	dcl     xmail_window_manager_$suppress_menu entry ();
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));

/* CONSTANTS */

	dcl     ALLOW_NEW		 bit (1) aligned init ("1"b) static options (constant);
	dcl     DONT_ALLOW_OLD	 bit (1) aligned init ("0"b) static options (constant);
	dcl     EXTENSION_ENAME	 char (22) init ("xmail_emacs_ext_mlist_") int static options (constant);
	dcl     MLIST_SUFFIX	 char (3) init ("mls") int static options (constant);
	dcl     ME_CHAR		 char (19) init ("xmail_create_mlist_") int static options (constant);
	dcl     ME_ENTRY		 entry variable init (xmail_create_mlist_);

/* EXTERNAL STATIC */

	dcl     iox_$user_io	 ptr ext static;
	dcl     xmail_err_$int_prog_err fixed bin (35) ext static;

/* BUILTINS */

	dcl     (codeptr, null, rtrim) builtin;
	dcl     (quit)		 condition;

/* INCLUDE FILES */

%include xmail_data;

/* BEGIN */

	restore_menu_needed = "0"b;
	status = 1;
	seg_dir = "";
	on condition (quit)
	     begin;
		if xmail_window_manager_$quit_handler ()
		then do;
		     if restore_menu_needed
		     then do;
			call xmail_window_manager_$restore_menu;
			call xmail_redisplay_$menu;
		     end;
		     status = 1;
		     if seg_dir ^= "" then call hcs_$delentry_file (seg_dir, seg_prefix || "." || MLIST_SUFFIX, (0));
		     go to EXIT;
		end;
	     end;

	if ext_ptr = null
	then do;
	     call hcs_$make_ptr (codeptr (ME_ENTRY), EXTENSION_ENAME, "", ext_ptr, code);
	     if code ^= 0 then call mlist_err (xmail_err_$int_prog_err, "Trying to locate extension.");
	     call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code);
	     if code ^= 0 then call mlist_err (xmail_err_$int_prog_err, "Trying to get extension pathname");
	     ext_pname = rtrim (ext_dir) || ">" || rtrim (EXTENSION_ENAME);
	end;

	call xmail_select_file_$caller_msg ("mailing list", MLIST_SUFFIX, "", DONT_ALLOW_OLD, ALLOW_NEW, seg_dir, seg_prefix, "Enter name of mailing list you wish to create ", unused_bit, unused_bit2, code);
	if code ^= 0 then return;

	seg_pname = rtrim (seg_dir) || ">" || rtrim (seg_prefix) || "." || MLIST_SUFFIX;

	call hcs_$append_branch (seg_dir, seg_prefix || "." || MLIST_SUFFIX, RW_ACCESS_BIN, code);
	if code ^= 0 then call mlist_err (xmail_err_$int_prog_err, "While creating mailing list.");

	call ioa_ ("...Please wait for editor...");

/* Check personalization option to remove and restore menus while editing */

	if xmail_data.remove_menus
	then do;
	     call xmail_window_manager_$suppress_menu ();
	     restore_menu_needed = "1"b;
	end;

	call emacs_ (iox_$user_io, seg_pname, ext_pname, null, code);

	if restore_menu_needed
	then do;
	     call xmail_window_manager_$restore_menu ();
	     call xmail_redisplay_$menu;
	     restore_menu_needed = "0"b;
	end;

	if code = 0
	then do;
	     status = 0;
	     mlist_name = seg_prefix;
	end;

	else do;
	     call xmail_window_manager_$reconnect ();
	     call hcs_$delentry_file (seg_dir, seg_prefix || "." || MLIST_SUFFIX, (0));

	     call ioa_ ("Mailing list ""^a"" not created.", seg_prefix);
	end;
EXIT:

	return;
%page;
/* Internal procedures. */

mlist_err: proc (P_code, P_str);

	dcl     P_code		 fixed bin (35);
	dcl     P_str		 char (*);

	call com_err_$suppress_name (P_code, ME_CHAR);
	go to EXIT;

     end mlist_err;

%page;
%include access_mode_values;

     end xmail_create_mlist_;




		    xmail_data_.cds                 05/28/86  1057.9rew 05/28/86  1025.9       15966



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


/* HISTORY COMMENTS:
  1) change(86-03-21,Blair), approve(86-03-21,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     This program creates the xmail data structure for the help search
     directories.
                                                   END HISTORY COMMENTS */

xmail_data_:
	proc;

dcl  create_data_segment_ entry (ptr, fixed bin (35));

dcl  1 cdsa	     aligned like cds_args;

dcl  code		     fixed bin (35);

dcl  name		     char (12) aligned static init
                         ("xmail_data_") options (constant),
     exclude_pad         (1) char (32) aligned static options (constant) init
		     ("pad*");

dcl (dim,
     addr,
     size,
     string)	     builtin;

%include xmail_help_data_;

dcl 1 xmail_help_data aligned,
      2 help_dirs,
        3 N fixed bin,
        3 dir_array (1) char(168);


/* Set up help directory search paths */

xmail_help_data.help_dirs.N = dim(xmail_help_data.dir_array, 1);

xmail_help_data.dir_array(1) = ">doc>ss>executive_mail";

/* Now set up call to create data base */

cdsa.sections (1).p = addr (xmail_help_data);
cdsa.sections (1).len = size (xmail_help_data);
cdsa.sections (1).struct_name = "xmail_help_data";
cdsa.seg_name = name;
cdsa.num_exclude_names = 1;
cdsa.exclude_array_ptr = addr (exclude_pad);
string (cdsa.switches) = "0"b;
cdsa.switches.have_text = "1"b;
call create_data_segment_ (addr (cdsa), code);

% include cds_args;

end xmail_data_;




		    xmail_default_fkeys_.pl1        12/02/84  1113.6rew 12/02/84  1015.0       20655



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

xmail_default_fkeys_: proc () returns (ptr) /* must be quick */;

/* BEGIN DESCRIPTION

Function: This procedure sets up a default structure of function_key_data
          containing  escape sequences instead of function keys.

History:  Originally part of xmail.pl1

   84-09-19 JG Backs: This was made into a separate module so it could be
   called from both xmail and xmail_Review_Defaults_ modules.

   84-11-04 JG Backs: Module name changed to include a trailing underscore
   (xmail_default_fkeys_) to be consistant with all other external procedures.
   Audit change.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     default		 ptr;
	dcl     i			 fixed bin;

/* STATIC */

	dcl     ESC		 init ("") char (1) static options (constant);
	dcl     PSEUDO_KEYS		 init ("?fpqrlheFPQRLHE") char (15) static options (constant);

/* BASED */

	dcl     default_fkey_seq	 char (default -> function_key_data.seq_len) based (default -> function_key_data.seq_ptr);
	dcl     system_area		 area based (get_system_free_area_ ());

/* ENTRIES */

	dcl     get_system_free_area_	 entry () returns (ptr);

/* BUILTINS */

	dcl     (length, null, substr) builtin;

/* INCLUDE FILES */

%include function_key_data;

/* BEGIN */

	function_key_data_highest = length (PSEUDO_KEYS);

	allocate function_key_data set (default) in (system_area);
	default -> function_key_data.version = function_key_data_version_1;
	default -> function_key_data.seq_len = 2 * function_key_data_highest;

	allocate default_fkey_seq in (system_area);
	do i = 1 to function_key_data_highest;
	     substr (default_fkey_seq, 2 * i - 1, 1) = ESC;
	     substr (default_fkey_seq, 2 * i, 1) = substr (PSEUDO_KEYS, i, 1);
	     default -> function_key_data.function_keys (i, KEY_PLAIN).sequence_index = 2 * i - 1;
	     default -> function_key_data.function_keys (i, KEY_PLAIN).sequence_length = 2;
	end;

	return (default);

     end xmail_default_fkeys_;




		    xmail_delete_dreply_.pl1        09/02/88  0759.6r w 09/02/88  0746.7       16497



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


/* Begin xmail_delete_dreply_.pl1 */
/* Written by R. Ignagni 1/4/82 

   83-06-27 DJ Schimke: Deleted declaration of unreferenced variable code.
*/
/* This proc deletes a deferred reply, if one exists, when the corresponding
   message is discared, or filed in another mbx (mail file) */

xmail_delete_dreply_: proc (seg_of_deletes_ptr);

/* Parameter */

	dcl     seg_of_deletes_ptr	 ptr;


/* Static */

	dcl     NAME		 char (20) static options (constant) init ("xmail_delete_dreply_");

/* Automatic */

	dcl     1 deletes		 based (seg_of_deletes_ptr),
		2 no_of_entries	 fixed bin,
		2 deletes_array	 (xn refer (no_of_entries)) char (25);


	dcl     deferred_seg_name	 char (32) var;
	dcl     idx		 fixed bin;

/* Entries */

	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));


/* Include */

%page;
%include xmail_data;
%page;


/* BEGIN */


	do idx = 1 to no_of_entries;
	     if deletes_array (idx) = "" then go to skip;
	     deferred_seg_name = deletes_array (idx);
	     call delete_$path ((xmail_data.mail_dir), (deferred_seg_name), "100100"b, NAME, (0));
skip:	end;
	call hcs_$set_bc_seg (seg_of_deletes_ptr, 36, (0)); /* keep first word */
	no_of_entries = 0;
	return;

     end xmail_delete_dreply_;





		    xmail_delete_mlist_.pl1         11/15/83  1511.9r w 11/15/83  1400.2       15669



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


xmail_delete_mlist_: proc (P_dir, P_file);

	dcl     (P_dir, P_file)	 char (*);
	dcl     code		 fixed bin (35);
	dcl     com_err_$suppress_name entry () options (variable);
	dcl     hcs_$delentry_file	 entry (char (*), char (*), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ME_CHAR		 char (19) init ("xmail_delete_mlist_");
	dcl     xmail_sw_$update_file	 entry (char (*));
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     rtrim		 builtin;
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     MLIST_SUFFIX	 char (3) init ("mls") int static options (constant);

	call hcs_$delentry_file (P_dir, P_file, code);
	if code ^= 0 then call delete_mlist_err (code, "Trying to delete mailing list.");

	call xmail_sw_$update_file (" ");
	call xmail_sw_$redisplay ();
	call ioa_ ("""^a"" mailing list was discarded.", rtrim (rtrim (P_file,
	     MLIST_SUFFIX), " ."));
	call timer_manager_$sleep (3, "11"b);

EXIT:

	return;

%page;
/* Internal procedures */

delete_mlist_err: proc (P_code, P_str);

	dcl     P_code		 fixed bin (35);
	dcl     P_str		 char (*);

	call com_err_$suppress_name (P_code, ME_CHAR, "^a", P_str);
	go to EXIT;

     end delete_mlist_err;

     end xmail_delete_mlist_;




		    xmail_delete_msgs_.pl1          11/15/83  1511.9r w 11/15/83  1400.2       40581



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


xmail_delete_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_pos_line, P_file_name);

/* Author unknown.

   83-06-27  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-09-14 DJ Schimke: Modified the handling of the error code from 
   mail_system_$mark_message_for_deletion to recognize and report an access 
   problem rather than reporting it as an "internal error." TR11955
*/

/* Parameter */

	dcl     (P_mailbox_ptr, P_curr_msgsp) ptr;
	dcl     P_file_name		 char (*);
	dcl     P_pos_line		 char (*);

/* Automatic */

	dcl     add_more_msg	 bit (1) aligned;
	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     message_no_string	 char (200) var;
	dcl     message_number	 fixed bin;
	dcl     message_ptr		 ptr;

/* Constant */

	dcl     ME_CHAR		 char (18) int static options (constant) init ("xmail_delete_msgs_");
	dcl     MORE_MSG		 char (12) int static options (constant) init (" ... <MORE> ");
	dcl     SP		 char (1) int static options (constant) init (" ");

/* Builtin */

	dcl     (char, length, ltrim, maxlength, null)
				 builtin;

/* Entries */

	dcl     ioa_		 entry () options (variable);
	dcl     mail_system_$mark_message_for_deletion entry (ptr, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_select_msgs_$next entry (ptr, ptr, char (*));
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));

/* External Static */

	dcl     mlsys_et_$cant_be_deleted fixed bin (35) ext;
	dcl     xmail_err_$no_curr_msgs fixed bin (35) ext;

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure.  This is an internal programming error.");

	if P_curr_msgsp = null
	then call xmail_error_$code_first (xmail_err_$no_curr_msgs, ME_CHAR, "i");
	else do;
		call xmail_validate_$curr_msgs (P_curr_msgsp, code);
		if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure.  This is an internal programming error.");
	     end;

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgsp;

	message_no_string = "";
	do i = 1 to curr_msgs.count;
	     message_number = curr_msgs.numbers (i);
	     if mailbox.messages (message_number).message_ptr = null
	     then do;
		     call mail_system_$read_message (mailbox_ptr, message_number, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", message_number);
		end;
	     message_ptr = mailbox.messages (message_number).message_ptr;
	     call mail_system_$mark_message_for_deletion (message_ptr, code);
	     if code = mlsys_et_$cant_be_deleted
	     then do;
		     call print_msg;
		     call xmail_error_$no_code (code, ME_CHAR, "q", "Sorry, unable to discard message ^d.^/You don't have permisson to delete messages in this mail file.", message_number);
		end;
	     else if code ^= 0
	     then do;
		     call print_msg;
		     call xmail_error_$no_code (code, ME_CHAR, "q", "Sorry, unable to discard message ^d.  This is an internal programming error.", message_number);
		end;

	     if length (message_no_string) + length (ltrim (char (message_number))) + length (SP) > maxlength (message_no_string)
	     then add_more_msg = "1"b;
	     else message_no_string = message_no_string || ltrim (char (message_number)) || SP;
	end;

	call print_msg;
	call xmail_select_msgs_$next (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

EXIT:
	return;

print_msg: proc ();
	call ioa_ ("Message^[s^;^] ^a ^[^a^;^s^] discarded from ""^a"".", (curr_msgs.count > 1), message_no_string, add_more_msg, MORE_MSG, P_file_name);
     end print_msg;
%page;
%include mlsys_mailbox;
%page;
%include xmail_curr_msg_info;

     end xmail_delete_msgs_;




		    xmail_dir_manager_.pl1          09/02/88  0759.6rew 09/02/88  0735.9      244449



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



/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-25 JG Backs: Modified xmail_upgrade internal procedure to initialize
     values for new personalize options: confirm_print_yn, include_original_yn,
     file_original_yn.  Combined duplicate code for setting default values into
     one internal procedure SET_DEFAULT, which is called for all options that
     set yes, no, or ask.
  2) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Add code to set default for allowing suppression of upper window
     when replying.
  3) change(86-02-26,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Change call to hcs_$make_seg to initiate_file_$create.  If the value
     segment cannot be initiated and the error is due to incorrect access, call
     the rebuild_xmail_value_seg_ routine to create a new value seg in the
     process dir.
  4) change(86-03-18,Blair), approve(86-03-18,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Make close_dir use the pathname of the value segment rather than a ptr to
     it.
  5) change(86-06-27,Blair), approve(86-07-15,MCR7447),
     audit(86-07-16,LJAdams), install(86-07-21,MR12.0-1100):
     Force access for xmail.errors if necessary when containing dir has "sma".
     TR 18355.  Don't check for execution access on the value segment since
     this causes problems when the user is in a different ring than the seg. TR
     20418.
  6) change(87-01-20,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Initialize msgs_as_mail to its default as part of updating version 4.1.
  7) change(88-06-28,Blair), approve(88-07-27,MCR7959),
     audit(88-08-30,RBarstad), install(88-09-02,MR12.2-1098):
     Fix various access bugs.  Call new entry  xmail_rebuild_value_seg_$copy
     when we  have read and no write access to to mlsys value seg. Add acls as
     necessary rather than replacing them each time xmail is invoked.
     Create the error segment in the pdir if we can't force access to the
     mlsys directory.
                                                   END HISTORY COMMENTS */

xmail_dir_manager_: proc ();

/* BEGIN DESCRIPTION */

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

     This subroutine has two entrypoints:

          open_dir --  makes sure that the xmail directory exists with
		   the proper contents (at least the following:
		   incoming.mbx link to the users default mbx,
		   outgoing.sv.mbx, xmail_data.value).
          close_dir -- cleans up the directory after use.

     Some information in the xmail_data structure is used by this
     subroutine and must be initialized prior to invocation.  The
     information that must be initialized is as follows:

          For open_dir:

               xmail_data.person
               xmail_data.project

          For close_dir:

	     xmail_data.value_seg

     The following information is initialized by open_dir:

          xmail_data.value_seg
          xmail_data.mail_dir

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

/* History:      Written by Suzanne Krupp 1/11/81

   83-08-11 DJ Schimke: Modified to use Person_id.mlsys as the xmail directory
   rather than Person_id.xmail.  If Person_id.xmail already existed the new
   name is added. Mailing lists have an added name with ".mls" as the suffix
   and the error_log segment is now xmail.error.

   83-09-14 DJ Schimke: Modified the error code handling of the value_$init
   call to ignore a "Segment already known to process" error. phx12785

   83-09-15 DJ Schimke: Modified the error code handling of the hcs_$make_seg
   call to report an inconsistent xmail directory instead of just saying it is
   an internal error when the user doesn't have access to xmail_data.value.
   phx12665

   83-09-15 DJ Schimke: Modified so user's xmail_data.value segment has access
   of Person_id.*.* rew rather than Person_id.Project_id.* rew. phx15877

   83-11-30 DJ Schimke: Modified to set the default values for the "Outgoing 
   Savefile" and "Save Outgoing Messages" personalization options if they have 
   never been set. This greatly simplifies the code that must handle these 
   options later. These changes and other "one-time" conversion code was 
   consolidated into the internal proc xmail_upgrade which compares the version
   number before deciding to make changes.
	   
   83-12-07 DJ Schimke: Modified xmail_upgrade to also initialize the value
   for acknowledge_yn if it has never been set.

   83-12-12 DJ Schimke: Modified to only look for the link to incoming_mbx (not
   chase) when determining whether to create the link.

   84-06-26 JG Backs: Modified the error code handling of hcs_$append_branchx
   call to report a user friendly message when the aim level of the home
   directory and the current process are different. TR phx17650.

   84-09-12 JG Backs: Modified internal procedure xmail_upgrade to initialize
   values for personalize options: lists_as_menus_yn, interactive_msgs_yn,
   always_escape_keys_yn, multics_mode_yn, remove_menus_yn.

   84-10-24 JG Backs: Modified the error code handling of the call to hcs_
   $status_long to accept error_table_$no_s_permission as valid.  This will
   permit users to link to mlsys or xmail directories under other projects
   without having "s" permission on the above directory.



END DESCRIPTION
*/

/* AUTOMATIC */

          dcl     a_mode                 bit (36) aligned;
	dcl     aim_code		 fixed bin (35);
	dcl     aim_dir_entry	 char (32);
	dcl     aim_home_dir	 char (168);
	dcl     aim_level_dir	 bit (72) aligned;
	dcl     aim_level_proc	 bit (72) aligned;
	dcl     aim_level_string	 char (32);
	dcl     answer_yn		 char (3) var;	/* value of yes, no, or ask */
	dcl     area_ptr		 ptr;
	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
          dcl     created_sw             bit (1) aligned;
	dcl     default_mbx		 char (32) var;
	dcl     error_seg_ptr	 ptr;
          dcl     ex_mode                bit (36) aligned;
	dcl     home_dir		 char (168);
	dcl     idx		 fixed bin;
	dcl     mlsys_dir_entry	 char (32);
	dcl     mlsys_dir_exists	 bit (1);
	dcl     mlsys_dir_path	 char (168);
	dcl     mlsys_dir_uid	 bit (36);
	dcl     save_mailbox	 char (32) var;
	dcl     save_message	 char (32) var;
	dcl     seg_name		 char (32);
	dcl     target		 char (168);
	dcl     user_name		 char (35) var;
	dcl     type		 fixed bin (2);
	dcl     unused_return	 char (32) var;
	dcl     user_project	 char (32) var;
	dcl     value_seg_ptr	 ptr;
	dcl     version		 char (32) var;
	dcl     xmail_dir_entry	 char (32);
	dcl     xmail_dir_exists	 bit (1);
	dcl     xmail_dir_path	 char (168);
	dcl     xmail_dir_uid	 bit (36);

	dcl     1 auto_status_branch	 like status_branch;
	dcl     1 auto_segment_acl_array automatic like segment_acl_entry;

/* BUILTINS */

	dcl     (addr, after, index, ltrim, null, rtrim, reverse, substr, sum)
				 builtin;

/* CONDITIONS */

	dcl     cleanup		 condition;

/* ENTRIES */

	dcl     aim_check_$equal	 entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
	dcl     com_err_		 entry () options (variable);
	dcl     convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     get_authorization_	 entry () returns (bit (72) aligned);
          dcl     get_pdir_              entry() returns(char(168));
	dcl     get_ring_		 entry () returns (fixed bin (3));
	dcl     get_system_free_area_	 entry () returns (ptr);
          dcl     hcs_$add_acl_entries   entry (char(*), char(*), ptr, fixed bin, fixed bin(35));
	dcl     hcs_$append_branchx	 entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
	dcl     hcs_$append_link	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$chname_file	 entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$get_access_class	 entry (char (*), char (*), bit (72) aligned, fixed bin (35));
          dcl     hcs_$get_user_access_modes entry (char(*), char(*), char(*), fixed bin, bit(36) aligned, bit(36) aligned,
	fixed bin(35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
          dcl     initiate_file_$create  entry (char(*), char(*), bit(*), ptr, bit(1) aligned, fixed bin(24), fixed bin(35));
	dcl     mlsys_utils_$create_mailbox entry (char (*), char (*), fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     user_info_$homedir	 entry (char (*));
	dcl     value_$init_seg	 entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
          dcl     xmail_rebuild_value_seg_ entry (ptr, fixed bin (35));
          dcl     xmail_rebuild_value_seg_$copy entry (ptr, fixed bin (35));
	dcl     xmail_value_$get_no_validate entry (char (*), char (*) var, fixed bin (35));
	dcl     xmail_value_$set	 entry (char (*), char (*) var, char (*) var, fixed bin (35));

/* EXTERNAL STATIC */

	dcl     error_table_$ai_restricted fixed bin (35) ext static;
	dcl     error_table_$badcall	 fixed bin (35) ext static;
	dcl     error_table_$incorrect_access fixed bin (35) ext static;
	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     error_table_$namedup	 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$nomatch	 fixed bin (35) ext static;
	dcl     error_table_$no_s_permission fixed bin (35) ext static;
          dcl     error_table_$no_r_permission fixed bin (35) ext static;
	dcl     error_table_$no_w_permission fixed bin (35) ext static;
	dcl     error_table_$segknown	 fixed bin (35) ext static;
	dcl     error_table_$segnamedup fixed bin (35) ext static;
	dcl     xmail_err_$exit_now	 fixed bin (35) ext static;

/* CONSTANTS */

	dcl     ASK		 char (3) init ("ask") int static options (constant);
	dcl     CHASE		 fixed bin (1) init (1) int static options (constant);
	dcl     CREATE_DIR		 fixed bin (1) init (1) int static options (constant);
	dcl     ERROR_LOG_SEGMENT	 char (11) init ("xmail.error") int static options (constant);
	dcl     INCOMING_MBX	 char (32) var init ("incoming.mbx") int static options (constant);
	dcl     MBX_SUFFIX		 char (4) init (".mbx") int static options (constant);
	dcl     MLSYS_DIR_SUFFIX	 char (6) init (".mlsys") int static options (constant);
	dcl     NO		 char (2) init ("no") int static options (constant);
	dcl     NO_CHASE		 fixed bin (1) init (0) int static options (constant);
	dcl     PERMANENT_SEG	 fixed bin int static options (constant) init (0);
	dcl     SEG_FORCE		 bit (6) init ("100100"b) int static options (constant);
	dcl     SYSTEM_LOW		 char (32) init ("system_low") int static options (constant);
	dcl     TERM_FILE_TRUNC_BC	 bit (2) static options (constant) initial ("11"b);
	dcl     USE_ENTIRE_SEG	 fixed bin (19) int static options (constant) init (0);
	dcl     VALUE_SEG_NAME	 char (32) var init ("xmail_data.value") int static options (constant);
	dcl     VERSION		 char (7) init ("version") int static options (constant);
	dcl     XMAIL_DIR_SUFFIX	 char (6) init (".xmail") int static options (constant);
	dcl     YES		 char (3) init ("yes") int static options (constant);
	dcl     (
	/*** names of personalization options ***/
	        ACKNOWLEDGE		 char (14) init ("acknowledge_yn"),
	        ALWAYS_ESCAPE	 char (21) init ("always_escape_keys_yn"),
	        CONFIRM_PRINT	 char (19) init ("confirm_print_yn"),
	        FILE_ORIGINAL	 char (16) init ("file_original_yn"),
	        INCLUDE_ORIGINAL	 char (19) init ("include_original_yn"),
	        ORIGINAL_IN_WINDOW     char (21) init ("original_up_window_yn"),
	        INTERACTIVE_MSGS	 char (19) init ("interactive_msgs_yn"),
	        LISTS_AS_MENUS	 char (17) init ("lists_as_menus_yn"),
                  MSGS_AS_MAIL           char (15) init ("msgs_as_mail_yn"),
	        MULTICS_MODE	 char (15) init ("multics_mode_yn"),
	        OUTGOING_SV_BOX	 char (32) init ("outgoing.sv.mbx"),
	        REMOVE_MENUS	 char (15) init ("remove_menus_yn"),
	        SAVE_MAILBOX	 char (15) init ("save_mailfile"),
	        SAVE_MESSAGE	 char (15) init ("save_message_yn")
	        )			 static options (constant);

%skip (3);
/* BEGIN */

	call com_err_ (error_table_$badcall, "xmail_dir_manager_", "This is not a valid entrypoint.");
	return;

open_dir: entry (code);

	code = 0;

	star_names_ptr = null ();
	star_entry_ptr = null ();
	on condition (cleanup) call CLEAN_UP;

	user_name = xmail_data.person;
	user_project = xmail_data.project;
	call user_info_$homedir (home_dir);

/* Find out if the xmail and mlsys directories exist in the home dir. */

	xmail_dir_entry = user_name || XMAIL_DIR_SUFFIX;
	mlsys_dir_entry = user_name || MLSYS_DIR_SUFFIX;
	xmail_dir_path = rtrim (home_dir) || ">" || xmail_dir_entry;
	mlsys_dir_path = rtrim (home_dir) || ">" || mlsys_dir_entry;

	call hcs_$status_long (home_dir, xmail_dir_entry, CHASE, addr (auto_status_branch), null (), code);
	if code = 0 | code = error_table_$no_s_permission /* accept no s */
	then do;
	     xmail_dir_exists = "1"b;
	     xmail_dir_uid = auto_status_branch.long.uid;
	end;
	else if code = error_table_$noentry then xmail_dir_exists = "0"b;
	else goto OPEN_EXIT;

	call hcs_$status_long (home_dir, mlsys_dir_entry, CHASE, addr (auto_status_branch), null (), code);
	if code = 0 | code = error_table_$no_s_permission /* accept no s */
	then do;
	     mlsys_dir_exists = "1"b;
	     mlsys_dir_uid = auto_status_branch.long.uid;
	end;
	else if code = error_table_$noentry then mlsys_dir_exists = "0"b;
	else goto OPEN_EXIT;

	if mlsys_dir_exists & xmail_dir_exists
	then if xmail_dir_uid ^= mlsys_dir_uid
	     then do;				/* ERROR */
		call ioa_ ("executive_mail (^a): With this version, xmail uses the mlsys", xmail_version);
		call ioa_ ("^5xdirectory for its work files. Since you already have both an xmail");
		call ioa_ ("^5xdirectory (^a) and the mlsys directory (^a),", xmail_dir_entry, mlsys_dir_entry);
		call ioa_ ("^5xxmail cannot rename its directory and continue. Please move");
		call ioa_ ("^5xeverything into the xmail directory and delete the mlsys directory.");
		call ioa_ ("^5xIf you have problems, contact your project or site administrator.");
		code = xmail_err_$exit_now;
		goto OPEN_EXIT;
	     end;

	if xmail_dir_exists & ^mlsys_dir_exists
	then do;					/* Add name "Person_id.mlsys" */
	     call hcs_$chname_file (home_dir, xmail_dir_entry, "", mlsys_dir_entry, code);
	     if code ^= 0 then goto OPEN_EXIT;
	end;

	if ^mlsys_dir_exists & ^xmail_dir_exists
	then do;					/* must create the mlsys dir */
	     call hcs_$append_branchx (home_dir, mlsys_dir_entry, SMA_ACCESS_BIN, get_ring_ (), user_name || ".*.*", CREATE_DIR, 1, (0), code);
	     if code ^= 0
	     then do;
		if code ^= error_table_$incorrect_access
		then goto OPEN_EXIT;
		else do;				/* incorrect access - now check aim level */

		     call expand_pathname_ (home_dir, aim_home_dir, aim_dir_entry, (0));
		     call hcs_$get_access_class (aim_home_dir, aim_dir_entry, aim_level_dir, aim_code);
		     if aim_code = 0
		     then do;
			aim_level_proc = get_authorization_ ();
			if ^aim_check_$equal (aim_level_proc, aim_level_dir)
			then do;
			     call convert_authorization_$to_string (aim_level_dir, aim_level_string, aim_code);
			     if aim_code = 0
			     then do;
				if aim_level_string = ""
				then aim_level_string = SYSTEM_LOW;
				call com_err_ (error_table_$ai_restricted, "executive_mail",
				     "^/  To invoke executive_mail," ||
				     "^/  logout and login using ""-auth ^a"".", aim_level_string);
			     end;
			     else call com_err_ (error_table_$ai_restricted, "executive_mail",
				     "^/  To invoke executive_mail," ||
				     "^/  logout and login with the proper authorization.");
			end;
			else call com_err_ (code, "executive_mail",
				"^/  Your home directory is inconsistent (no access)." ||
				"^/  Seek expert help.");
		     end;
		     else call com_err_ (code, "executive_mail",
			     "^/  Cannot determine authorization on home directory." ||
			     "^/  Seek expert help.");
		     code = xmail_err_$exit_now;
		     goto OPEN_EXIT;
		end;
	     end;
	end;

	xmail_dir_path = mlsys_dir_path;

/* Make a link to the users default mailbox (link "incoming.mbx" in xmail
     directory to "person_id.mbx" in users home directory). */

	call hcs_$status_minf (xmail_dir_path, (INCOMING_MBX), NO_CHASE, type, bit_count, code);
	if code = error_table_$noentry then do;
	     default_mbx = xmail_data.person || MBX_SUFFIX;
	     target = rtrim (home_dir) || ">" || default_mbx;
	     call hcs_$append_link (xmail_dir_path, (INCOMING_MBX), target, code);
	end;
          else if code = error_table_$incorrect_access then do;
               call com_err_ (code, "executive_mail",
              "^/  Check your authorization level." ||
              "^/  Incorrect access to ^a.", xmail_dir_path);
	     code = xmail_err_$exit_now;
	     goto OPEN_EXIT;
	     end;
	else if code ^= 0 
	then goto OPEN_EXIT;
	
/* Create the outgoing savebox in the users xmail directory if it is not
     already there. */

	call hcs_$status_minf (xmail_dir_path, OUTGOING_SV_BOX, CHASE, type, bit_count, code);
	if code = error_table_$noentry then do;
	     call mlsys_utils_$create_mailbox (xmail_dir_path, OUTGOING_SV_BOX, code);
	end;
	if code ^= 0 
	then goto OPEN_EXIT;
	
/* Create and initialize the xmail data segment (a value segment)
     in the user xmail directory if it is not already there. */

	auto_segment_acl_array.access_name = xmail_data.person || ".*.*";
	auto_segment_acl_array.mode = RW_ACCESS;
	auto_segment_acl_array.extended_mode = "0"b;

	call initiate_file_$create (xmail_dir_path, (VALUE_SEG_NAME), RW_ACCESS, value_seg_ptr, created_sw, bit_count, code); /* even if the value seg already exists, this call gets the pointer */
	if code = error_table_$incorrect_access  | code = error_table_$no_r_permission then do;
	     value_seg_ptr = null;
	     call xmail_rebuild_value_seg_ (value_seg_ptr, code);
	     if code ^= 0 then code = xmail_err_$exit_now;
	     end;
          else if code = error_table_$no_w_permission then do;
	     value_seg_ptr = null;
	     call xmail_rebuild_value_seg_$copy (value_seg_ptr, code);
	     if code ^= 0 then code = xmail_err_$exit_now;
	     end;
	else if code = error_table_$moderr then do;
	     call com_err_ (code, "executive_mail", "^/Your mail system directory is inconsistent (no access). Seek expert help.");
	     code = xmail_err_$exit_now;
	end;
	else if code = 0  then do;			/* Give the user access under all accounts */
               xmail_data.value_seg_pathname = mlsys_dir_path;
	     call hcs_$get_user_access_modes (xmail_dir_path, (VALUE_SEG_NAME), "", -1, a_mode, ex_mode, code);
	     if code = 0 then do;
		if a_mode ^= RW_ACCESS then do;
		     call hcs_$add_acl_entries (xmail_dir_path, (VALUE_SEG_NAME), addr (auto_segment_acl_array), 1, code);
		     if code ^= 0 then goto OPEN_EXIT;
		     end;
		end;
	     else goto OPEN_EXIT;
	end;					
	if code ^= 0 & code ^= error_table_$segknown & code ^= error_table_$namedup
	then goto OPEN_EXIT;

	if created_sw then
	call value_$init_seg (value_seg_ptr, PERMANENT_SEG, null, USE_ENTIRE_SEG, code);
	if code ^= 0 & code ^= error_table_$segknown
	then goto OPEN_EXIT;

	xmail_data.mail_dir = xmail_dir_path;

	call xmail_upgrade;				/* update to current version if necessary */

/* Truncate the error log segment. */

	call initiate_file_ (xmail_dir_path, ERROR_LOG_SEGMENT, RW_ACCESS, error_seg_ptr, bit_count, code);
	bit_count = 0;
	if code = 0
	then call terminate_file_ (error_seg_ptr, bit_count, TERM_FILE_TRUNC_BC, code);
	if code = error_table_$moderr | 
             code = error_table_$no_w_permission |
             code = error_table_$no_r_permission then do;
	     call hcs_$status_long (home_dir, mlsys_dir_entry, CHASE, addr (auto_status_branch),  null (), code);
/* hcs_$status_long returns a 5 bit mode with the 4 bit set on when the entry is a dir */
	     if code = 0  
               then if substr(auto_status_branch.mode, 3, 3) = SMA_ACCESS
		then do;
		     call hcs_$get_user_access_modes (xmail_dir_path,(ERROR_LOG_SEGMENT),"", -1, a_mode, ex_mode, code);
		     if a_mode ^= RW_ACCESS then do;
			call hcs_$add_acl_entries (xmail_dir_path, (ERROR_LOG_SEGMENT), addr(auto_segment_acl_array), 1, code);
			if code ^= 0 then goto OPEN_EXIT;
			end;
		     end;
		else do;
		     call initiate_file_$create (get_pdir_(), (ERROR_LOG_SEGMENT), RW_ACCESS, error_seg_ptr, created_sw, bit_count, code);
		     bit_count = 0;
		     xmail_data.error_seg_in_pdir = "1"b;
		     if code = 0 
			then call terminate_file_ (error_seg_ptr, bit_count, TERM_FILE_TRUNC_BC, code);
		     end;
	     end;
	if code = error_table_$noentry then code = 0;

OPEN_EXIT:
	call CLEAN_UP;
	return;					/* open_dir entry */

close_dir: entry ();

	 dcl term_ entry (char(*), char(*), fixed bin(35));
	 dcl dirname char(168);
           dcl return_code fixed bin(35);
	 
	 dirname = xmail_data.value_seg_pathname;
	 call term_ (rtrim(dirname), (VALUE_SEG_NAME), return_code);

	return;					/* close_dir entry */

xmail_upgrade: proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This code updates the user's xmail directory for version upgrades. These are things  */
/* we can skip if the version matches.  The comparison depends on the 10 character      */
/* xmail_version to be given as: "2.0a EXL" or such so the major and minor version      */
/* numbers are first in the string. The intention is to ignore differences in the       */
/* version which are only EXL identifiers etc.				        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	call xmail_value_$get_no_validate (VERSION, version, code);
	if code ^= 0 then version = "";
	else do;
	     version = ltrim (version);
	     idx = index (version, " ");
	     if idx ^= 0
	     then version = substr (version, 1, idx - 1);
	end;
	if version = xmail_version then goto UPGRADE_EXIT;

/* Establish default values for personalization options */

	call xmail_value_$get_no_validate (SAVE_MESSAGE, save_message, code);
	if code ^= 0 then save_message = "";
	call xmail_value_$get_no_validate (SAVE_MAILBOX, save_mailbox, code);
	if code ^= 0 then save_mailbox = "";

	if save_message = "" then do;
	     call xmail_value_$set (SAVE_MESSAGE, (YES), unused_return, code); /* don't change the automatic copy, we'll need it later */
	     if code ^= 0 then goto UPGRADE_EXIT;
	end;

	if save_mailbox = "" then do;
	     if save_message = "" then call xmail_value_$set (SAVE_MAILBOX, (ASK), save_mailbox, code);
	     else call xmail_value_$set (SAVE_MAILBOX, "outgoing", save_mailbox, code);
	     if code ^= 0 then goto UPGRADE_EXIT;
	end;

	call SET_DEFAULT (ACKNOWLEDGE, (NO));
	call SET_DEFAULT (LISTS_AS_MENUS, (NO));
	call SET_DEFAULT (INTERACTIVE_MSGS, (YES));
	call SET_DEFAULT (ALWAYS_ESCAPE, (NO));
	call SET_DEFAULT (MULTICS_MODE, (NO));
          call SET_DEFAULT (MSGS_AS_MAIL, (NO));
	call SET_DEFAULT (REMOVE_MENUS, (NO));
	call SET_DEFAULT (CONFIRM_PRINT, (YES));
	call SET_DEFAULT (INCLUDE_ORIGINAL, (NO));
	call SET_DEFAULT (FILE_ORIGINAL, (NO));
	call SET_DEFAULT (ORIGINAL_IN_WINDOW, (YES));
	

/* Add the current suffix to any existing mailing lists. */
	area_ptr = get_system_free_area_ ();

	star_entry_count = 0;
	call hcs_$star_ (xmail_dir_path, "**.mlist", star_ALL_ENTRIES, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code);
	if code = error_table_$nomatch then code = 0;
	else if code ^= 0				/* other error */
	then goto UPGRADE_EXIT;

	if star_entry_count > 0 then
	     do idx = 1 to star_entry_count;
		seg_name = star_names (star_entries (idx).nindex);
		call hcs_$chname_file (xmail_dir_path, rtrim (seg_name), "",
		     reverse (after (reverse (rtrim (seg_name)), reverse (".mlist"))) || ".mls", code);
		if code ^= 0 & code ^= error_table_$segnamedup then goto UPGRADE_EXIT;
	     end;

/* Rename the old error log segment if it exists. */

	call hcs_$status_minf (xmail_dir_path, user_name || ".error", NO_CHASE, type, bit_count, code);
	if code = 0 then do;
	     call hcs_$chname_file (xmail_dir_path, user_name || ".error", user_name || ".xmail_error", ERROR_LOG_SEGMENT, code);
	     if code = error_table_$segnamedup | code = error_table_$namedup then do;
		call delete_$path (xmail_dir_path, user_name || ".error", SEG_FORCE, "", code);
	     end;
	end;
	else if code = error_table_$noentry then code = 0;
	if code ^= 0
	then goto UPGRADE_EXIT;

/* If everything else succeeds, set the new version in the xmail value segment. */

	call xmail_value_$set (VERSION, (xmail_version), version, code);
	if code ^= 0 then goto UPGRADE_EXIT;

UPGRADE_EXIT:
	return;

SET_DEFAULT: proc (sd_value_name, sd_default);

/* PARAMETERS */

	dcl     sd_value_name          char (*);
	dcl     sd_default             char (*);

/* BEGIN */

	call xmail_value_$get_no_validate (sd_value_name, answer_yn, code);
	if code ^= 0 | answer_yn = ""
	then do;
	     call xmail_value_$set (sd_value_name, (sd_default), answer_yn, code);
	     if code ^= 0
	     then goto UPGRADE_EXIT;
	end;

     end SET_DEFAULT;

    end xmail_upgrade;


CLEAN_UP: proc;
	if star_names_ptr ^= null () then free star_names;/* order is important */
	if star_entry_ptr ^= null () then free star_entries;
     end CLEAN_UP;

%include acl_structures;
%page;
%include access_mode_values;
%page;
%include star_structures;
%page;
%include status_structures;
%page;
%include xmail_data;

     end xmail_dir_manager_;




		    xmail_discard_file_.pl1         09/02/88  0759.6r w 09/02/88  0746.7       33606



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





/****^  HISTORY COMMENTS:
  1) change(86-03-06,Blair), approve(86-03-06,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     If user types "yes" to "Do you want to discard the file", then ask him
     whether or not he wishes to print the messages in the file.
                                                   END HISTORY COMMENTS */


/* Begin xmail_discard_file_ */
/* Created by R. Ignagni  Oct 1981
 
   83-06-27  DJ Schimke: Declared rtrim builtin. Deleted dcls for unreferenced
   ioa_$nnl, xmail_err_$int_prog_err, and xmail_error_$no_code.

   83-09-14  DJ Schimke: Modified to use xmail_data.mail_dir rather than 
   getting its own pathname to the xmail directory. Added xmail_data include
   file. Deleted dcls for person, project, and user_info_$whoami.

   83-10-06  DJ Schimke: Changed call to xmail_get_str_ to call 
   xmail_get_str_$yes_no.
*/

xmail_discard_file_: proc (P_mailbox_ptr, P_curr_msgsp, P_file_name, P_discarded);
	user_message1 = "Do you want to discard mail file ""^a""? ";
	user_message2 = "^/Mail file ""^a"" was discarded.";
	user_message3 = "Do you want to print the messages in ""^a""? ";
	delete_switches = "100111"b;
	go to START;

link: entry (P_mailbox_ptr, P_curr_msgsp, P_file_name, P_discarded);

	user_message1 = "Do you want to remove the link to mail file ""^a""? ";
	user_message2 = "^/Link to mail file ""^a"" was removed.";
	delete_switches = "100110"b;
	go to START;

/* Params */

	dcl     P_mailbox_ptr	 ptr;
	dcl     P_curr_msgsp	 ptr;
	dcl     P_file_name		 char (*);
	dcl     P_discarded		 bit (1) aligned;

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     delete_switches	 bit (6);
	dcl     prompt_string	 char (80) var;
	dcl     user_message1	 char (50) varying;
	dcl     user_message2	 char (40) varying;
          dcl     user_message3          char (50) varying;
	dcl     yes_sw		 bit (1) aligned;

/* Entries */

	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_dprint_msgs_	 entry (ptr, ptr);

/* Builtin */

	dcl     (null, rtrim)	 builtin;

/* Constant */

	dcl     ME_CHAR		 char (19) init ("xmail_discard_file_") int static options (constant);

/* Include */

%page;
%include xmail_data;

START:

	P_discarded = "0"b;

	call ioa_$rsnnl (user_message1, prompt_string, (0), P_file_name);
	call xmail_get_str_$yes_no (prompt_string, yes_sw);
	if yes_sw then do;
	     if P_curr_msgsp ^= null ()
	     then do;
		call ioa_$rsnnl (user_message3, prompt_string, (0), P_file_name);
		call xmail_get_str_$yes_no (prompt_string, yes_sw);
		if yes_sw then
		call xmail_dprint_msgs_ (P_mailbox_ptr, P_curr_msgsp);
		call ioa_ ("The messages in ""^a"" were ^[not ^]submitted for printing .", P_file_name, ^yes_sw);
	     end;

	     call delete_$path ((xmail_data.mail_dir), rtrim (P_file_name)
		|| ".sv.mbx", delete_switches, ME_CHAR, code);
	     call ioa_ (user_message2, P_file_name);
	     P_discarded = "1"b;
	end;
EXIT:

	return;

     end xmail_discard_file_;




		    xmail_display_help_.pl1         09/13/88  1327.0rew 09/13/88  1312.2       28593



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



/****^  HISTORY COMMENTS:
  1) change(86-01-22,LJAdams), approve(86-01-22,MCR7327),
     audit(86-04-22,RBarstad), install(86-04-25,MR12.0-1048):
     Added ssu references so subsystem calls to help_ will work properly.
     Added include files "help_args" and "xmail_data".
  2) change(86-04-21,Blair), approve(86-04-21,MCR7358),
     audit(86-04-22,RBarstad), install(86-05-28,MR12.0-1062):
     Changed to use a cds segment to provide the help dir pathname. This has
     caused xmail_help.incl.pl1 to be replaced by xmail_help_data_.incl.pl1.
  3) change(87-09-03,LJAdams), approve(87-09-03,MCR7766),
     audit(88-08-04,GDixon), install(88-09-13,MR12.2-1109):
     Changed Vhelp_args_2 to Vhelp_args_3.
                                                   END HISTORY COMMENTS */

xmail_display_help_: proc (P_seg_name, P_info_name, P_code);

	dcl     (P_seg_name, P_info_name) char (*);
	dcl     P_code		 fixed bin (35);

	dcl     code		 fixed bin (35);
	dcl     ME_CHAR		 char (19) init ("xmail_display_help_") int static options (constant);
          dcl     ME_HELP_SUFFIX         char (10) init ("info") int static options (constant);
          dcl     ME_SEARCH_LIST         char (4) init ("info") int static options (constant);
	dcl     (error_table_$nomatch, xmail_err_$no_help_available, xmail_err_$unable_to_get_help) fixed bin (35) ext;

	dcl     (addr, dim, null)		builtin;

          dcl     cleanup condition;
		 

	P_code = 0;
          Phelp_args = null;
	
          on cleanup
             call help_$term ("xmail", Phelp_args, (0));
	
	call help_$init (ME_CHAR, ME_SEARCH_LIST, "", Vhelp_args_3, Phelp_args, code);
	if code ^= 0 then go to DH_ERR;

	help_args.Nsearch_dirs = dim(xmail_HELP_DIRS.path, 1);
	help_args.search_dirs  = xmail_HELP_DIRS.path;
	help_args.Sctl.all = "1"b;			/* No questions asked */
	help_args.Npaths = 1;
	help_args.path (1).value = P_seg_name;
	help_args.path (1).info_name = P_info_name;
	help_args.path (1).S.pn_ctl_arg = "0"b;
	help_args.path (1).S.info_name_not_starname = "0"b;
	
	call help_ (ME_CHAR, Phelp_args, ME_HELP_SUFFIX, (0), code);
	if code ^= 0 then go to DH_ERR;

	go to DH_EXIT;

DH_ERR:

	if code = error_table_$nomatch
	then P_code = xmail_err_$no_help_available;
	else P_code = xmail_err_$unable_to_get_help;

DH_EXIT:

          call help_$term ("xmail", Phelp_args, (0));

%page;
%include xmail_help_data_;
%page;
%include help_args_;
%page;
%include xmail_data;
%page;
%include iox_dcls;

     end xmail_display_help_;




		    xmail_display_menu_.pl1         09/02/88  0759.6r w 09/02/88  0749.3       34173



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

/* Written March 1982 by R. Ignagni 
   
   83-06-27  DJ Schimke: Deleted dcls for unreferenced addr, cleanup, iox_, 
   iox_, iox_, length, null, and xmail_leave_menu.

   83-09-14  DJ Schimke: Added code to check the value of more_mode for the 
   bottom window before doing the clear_to_end_of_window call. The call to
   clear_to_end_of_window was added for more_mode=wrap (phx11860) and should
   not be done for fold mode. phx12565
*/
xmail_display_menu_: proc (menup, sw_no_lines, code);


	dcl     sw_no_lines		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     menup		 ptr;

	dcl     addr		 builtin;
	dcl     1 auto_mode_value	 automatic like mode_value;
	dcl     mode_str		 char (512);

	dcl     iox_$modes		 entry (ptr, char (*), char (*), fixed bin (35));
	dcl     mode_string_$get_mode	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     xmail_sw_$update_file	 entry (char (*));
	dcl     xmail_sw_$update_file_info entry (char (*));
	dcl     xmail_sw_$update_position entry (char (*));
	dcl     xmail_sw_$update_usage entry (char (*));
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     xmail_error_$code_last entry options (variable);
	dcl     NAME		 char (19) static options (constant) init ("xmail_display_menu_");


MAIN:

	code = 0;

	call xmail_sw_$update_file (" ");
	call xmail_sw_$update_file_info (" ");
	call xmail_sw_$update_position (" ");
	call xmail_sw_$update_usage (" ");
	call xmail_sw_$redisplay ();

	call DISPLAY;

	call iox_$modes (xmail_windows.bottom.iocb, "", mode_str, code);
	if code ^= 0 then go to ERROR;
	auto_mode_value.version = mode_value_version_3;
	call mode_string_$get_mode (mode_str, "more_mode", addr (auto_mode_value), code);
	if code ^= 0 then go to ERROR;
	if auto_mode_value.char_value ^= "fold" then
	     call window_$clear_to_end_of_window (xmail_windows.bottom.iocb, (0));
	return;

ERROR:	call xmail_error_$code_last (code, NAME, "s", "A program error has occurred for which no automatic correction is known.");


%page;
DISPLAY: proc;

	dcl     1 actual_menu_rqmts	 aligned like menu_requirements;

	dcl     xmail_err_$insuff_room_for_window ext static fixed bin (35);

	dcl     xmail_window_manager_$set_menu_window_size entry (fixed bin, fixed bin (35));
	dcl     xmail_window_manager_$set_sw_size entry (fixed bin, fixed bin (35));

	dcl     xmail_redisplay_$status_window entry ();
	dcl     xmail_redisplay_$menu	 entry ();

	actual_menu_rqmts.version = menu_requirements_version_1;
	call menu_$describe (menup, addr (actual_menu_rqmts), code);
	if code ^= 0 then goto ERROR;

	if actual_menu_rqmts.width_needed > xmail_windows.menu.width
	then code = xmail_err_$insuff_room_for_window;
	else do;
	     call xmail_window_manager_$set_sw_size (sw_no_lines, code);
	     if code = 0
	     then do;
		call xmail_redisplay_$status_window ();
		call xmail_window_manager_$set_menu_window_size (actual_menu_rqmts.lines_needed, code);
	     end;
	     if code = 0
	     then call xmail_redisplay_$menu ();
	end;
	if code = 0 then return;
	else go to ERROR;

     end DISPLAY;
%page;
%include mode_string_info;
%page;
%include xmail_data;
%page;
%include xmail_windows;
%page;
%include menu_dcls;
%page;
%include window_dcls;
%page;
%include xmail_help_infos;
%page;
%include xmail_responses;

     end xmail_display_menu_;




		    xmail_display_mlist_.pl1        09/11/84  1529.8r w 09/10/84  1509.5       36315



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


xmail_display_mlist_: proc (P_dname, P_ename);

/*  Author unknown.

    83-06-27  DJ Schimke: Deleted unreferenced seg and substr. Declared length
    builtin. Replaced call to hcs$initiate_count with initiate_file_ and call
    to hcs$_terminate_noname with terminate_file.
*/
/* Parameter */

	dcl     (P_dname, P_ename)	 char (*);

/* Automatic */

	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     seg_len		 fixed bin (21);
	dcl     seg_ptr		 ptr;


/* Entries */

	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);

/* External Static */

	dcl     iox_$user_output	 ptr ext static;
	dcl     xmail_err_$int_prog_err fixed bin (35) ext static;

/* Constant */

	dcl     LOG		 char (1) init ("l") int static options (constant);
	dcl     MLIST_SUFFIX	 char (3) init ("mls") int static options (constant);
	dcl     NAME		 char (20) init ("xmail_display_mlist_") int static options (constant);
	dcl     READ		 bit (3) init ("100"b) int static options (constant);
	dcl     TERM_FILE_TERM	 bit (3) init ("001"b) int static options (constant);

/* Builtin */

	dcl     (addr, before, divide, length, null) builtin;

	seg_ptr = null;

	call initiate_file_ (P_dname, P_ename, READ, seg_ptr, bit_count, code);
	if seg_ptr = null then call display_mlist_err (xmail_err_$int_prog_err, "Cannot initiate mailing list.");

	seg_len = divide (bit_count + 8, 9, 21, 0);

	call window_$clear_window (iox_$user_output, (0));/* ignore error */

	call format_and_display_header ();

	call iox_$put_chars (iox_$user_output, seg_ptr, seg_len, code);
	if code ^= 0 then call display_mlist_err (xmail_err_$int_prog_err, "Cannot display mailing list");

	call term_seg ();

EXIT:

	return;

%page;

term_seg: proc ();

	if seg_ptr ^= null
	then call terminate_file_ (seg_ptr, bit_count, TERM_FILE_TERM, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, LOG, "Unable to terminate mailing list. This is an internal error.");
     end term_seg;

display_mlist_err: proc (P_code, P_str);

	dcl     P_code		 fixed bin (35);
	dcl     P_str		 char (*);

	call xmail_error_$code_first (P_code, NAME, LOG, "^a", P_str);
	call term_seg ();
	go to EXIT;

     end display_mlist_err;

format_and_display_header: proc ();

	dcl     1 auto_window_position_info like window_position_info;

	dcl     pad_len		 fixed bin;
	dcl     text_len		 fixed bin;
	dcl     code		 fixed bin (35);

	auto_window_position_info.version = window_position_info_version;
	call iox_$control (iox_$user_output, "get_window_info", addr (auto_window_position_info), code);
	if code ^= 0 then call display_mlist_err (xmail_err_$int_prog_err, "While getting window info.");
	text_len = length ("*** Mailing List:  " || before (P_ename, "." || MLIST_SUFFIX) || " ***");
	pad_len = divide (auto_window_position_info.width - text_len, 2, 17, 0);

	call ioa_ ("^vx*** Mailing List:  ^a ***^/", pad_len, before (P_ename, "." || MLIST_SUFFIX));

     end format_and_display_header;

%page;
%include window_control_info;

     end xmail_display_mlist_;




		    xmail_display_msgs_.pl1         10/29/86  1508.6rew 10/29/86  1425.1       55719



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




/****^  HISTORY COMMENTS:
  1) change(86-02-06,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Add call to set the seen switch after the message is displayed.
  2) change(86-10-15,Blair), approve(86-10-15,MCR7564),
     audit(86-10-28,RBarstad), install(86-10-29,MR12.0-1201):
     Set the envelope_format_mode to DEFAULT so that the "Sender:" field will
     be displayed when the author and sender of the message are not the same.
     Fixes error_list 129.
                                                   END HISTORY COMMENTS */


xmail_display_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_iocb_ptr);

/* Author unknown.

   83-07-05  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.
*/

/* Parameter */

	dcl     (P_mailbox_ptr, P_curr_msgsp, P_iocb_ptr) ptr;

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     formfeed		 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     iocb_ptr		 ptr;
	dcl     message_num		 fixed bin;

	dcl     1 auto_format_message_options like format_message_options;
	dcl     1 auto_window_position_info like window_position_info;

/* Builtin */

	dcl     (addr, null)	 builtin;

/* Entries */

	dcl     get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
	dcl     ioa_$ioa_switch	 entry () options (variable);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     mail_system_$acknowledge_message entry (ptr, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
          dcl     mail_system_$set_message_switch entry (ptr, char (4) aligned, bit (1) aligned, fixed bin (35));
	dcl     mlsys_utils_$print_message entry (ptr, ptr, ptr, fixed bin (35));
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));

/* External Static */

	dcl     error_table_$no_operation fixed bin (35) ext static;
	dcl     xmail_err_$no_curr_msgs fixed bin (35) ext static;

/* Constant */

	dcl     ME_CHAR		 char (19) int static options (constant) init ("xmail_display_msgs_");

	formfeed = "0"b;
	call main ();
	return;

ff:  entry (P_mailbox_ptr, P_curr_msgsp, P_iocb_ptr);

	formfeed = "1"b;
	call main ();
	return;

main: proc ();
	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure.  This is an internal programming error.");

	if P_curr_msgsp = null
	then call xmail_error_$code_first (xmail_err_$no_curr_msgs, ME_CHAR, "i");
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure.  This is an internal programming error.");
	end;

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgsp;
	iocb_ptr = P_iocb_ptr;

	auto_window_position_info.version = window_position_info_version;
	call iox_$control (iocb_ptr, "get_window_info", addr (auto_window_position_info), code);
	if code = 0
	then auto_format_message_options.line_length = auto_window_position_info.width;
	else if code = error_table_$no_operation then do;
	     auto_format_message_options.line_length = get_line_length_$switch (iocb_ptr, (0)); /* Output could be going to file */
	     code = 0;
	end;
	else call xmail_error_$no_code (code, ME_CHAR, "q", "Cannot get width of user window. This is an internal programming error.");

	auto_format_message_options.version = FORMAT_MESSAGE_OPTIONS_VERSION_1;
	auto_format_message_options.envelope_formatting_mode = DEFAULT_FORMATTING_MODE;
	auto_format_message_options.header_formatting_mode = DEFAULT_FORMATTING_MODE;
	auto_format_message_options.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE;
	auto_format_message_options.include_body = "1"b;

	do i = 1 to curr_msgs.count;
	     message_num = curr_msgs.numbers (i);
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		call mail_system_$read_message (mailbox_ptr, message_num, code);
		if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
	     end;
	     message_ptr = mailbox.messages (message_num).message_ptr;
	     if ^message.seen
		then call mail_system_$set_message_switch (message_ptr, PER_MESSAGE_SEEN_SWITCH_TYPE, "1"b, (0));
	     if message.must_be_acknowledged
	     then do;
		call mail_system_$acknowledge_message (message_ptr, code);
		if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to send acknowledgement for message ^d.", message_num);
	     end;
	     call ioa_$ioa_switch (iocb_ptr, "^[^|^]^x#^d^[^x(^d^xline^[s^])^]:", (formfeed & i > 1), message_num, (message.total_lines ^= -1), message.total_lines, (message.total_lines ^= 1));
	     call mlsys_utils_$print_message (message_ptr, addr (auto_format_message_options), iocb_ptr, code);
	     if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to display message ^d.  This is an internal programming error.", message_num);
	     call ioa_$ioa_switch (iocb_ptr, " ---(^d)---", message_num);
	     call iox_$control (iocb_ptr, "reset_more", null (), (0));
	end;					/* do while */

     end main;

%include mlsys_format_options;
%page;
%include rdm_switch_types;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_message;
%page;
%include window_control_info;
%page;
%include xmail_curr_msg_info;

     end xmail_display_msgs_;




		    xmail_dprint_mlist_.pl1         10/28/88  1416.3r w 10/28/88  1302.1       30006



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



/****^  HISTORY COMMENTS:
  1) change(86-02-27,Blair), approve(86-02-27,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-26 Joanne Backs: Modified to not put in the defaults for copies,
     lmargin and notify in auto_dprint_arg before printing.  These are now
     personalization options and will be filled in by xmail_print_$submit_file.
     
     85-04-02 Joanne Backs: Deleted call to ioa_ to display user message.  Added
     the call to xmail_print_ so messages when printing would be consistant.
  2) change(87-05-10,Gilcrease), approve(87-05-15,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Update to version 9 dprint_arg.
                                                   END HISTORY COMMENTS */


xmail_dprint_mlist_: proc (P_dir, P_file);

/* BEGIN DESCRIPTION 

history:
   Written:  by ?? 

   82-10-11 Dave Schimke: Modified to use dp_args version 7 

   84-09-27 Joanne Backs: Modified to use dp_args version 8 

END DESCRIPTION 
*/

/* PARAMETERS */

	dcl     (P_dir, P_file)	 char (*);

/* AUTOMATIC */

	dcl     code		 fixed bin (35);
	dcl     1 auto_dprint_arg	 like dprint_arg;

/* BUILTINS */

	dcl     addr		 builtin;

/* ENTRIES */

	dcl     com_err_$suppress_name entry () options (variable);
	dcl     xmail_print_$delete_file entry (char (*), char (*), fixed bin (35));
	dcl     xmail_print_$submit_file entry (char (*), char (*), char (*), ptr, fixed bin (35));

/* EXTERNAL STATIC */

	dcl     xmail_err_$int_prog_err fixed bin (35) ext static;

/* CONSTANTS */

	dcl     ME_CHAR		 char (19) init ("xmail_dprint_mlist_") int static options (constant);

/* INCLUDE FILES */

%include dprint_arg;

/* BEGIN */

	auto_dprint_arg.version = dprint_arg_version_9;
	auto_dprint_arg.delete = 0;
	auto_dprint_arg.carriage_control = "0"b;
	auto_dprint_arg.line_lth = -1;
	auto_dprint_arg.page_lth = -1;
	auto_dprint_arg.top_label = "";
	auto_dprint_arg.bottom_label = "";
	auto_dprint_arg.form_name = "";
	auto_dprint_arg.chan_stop_path = "";
	auto_dprint_arg.request_type = "printer";
	auto_dprint_arg.defer_until_process_termination = 0;

	call xmail_print_$submit_file (P_dir, P_file, "", addr (auto_dprint_arg), code);
	if code ^= 0 then call dprint_mlist_err (xmail_err_$int_prog_err, "Trying to submit dprint request.");

EXIT:

	return;


/* INTERNAL PROCEDURES */

dprint_mlist_err: proc (P_code, P_str);

	dcl     P_str		 char (*);
	dcl     P_code		 fixed bin (35);

	call com_err_$suppress_name (P_code, ME_CHAR, "^a", P_str);
	call xmail_print_$delete_file (P_dir, P_file, (0));
	go to EXIT;

     end dprint_mlist_err;

    end xmail_dprint_mlist_;




		    xmail_dprint_msgs_.pl1          10/28/88  1416.3r w 10/28/88  1302.1       89388



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




/****^  HISTORY COMMENTS:
  1) change(86-02-27,Blair), approve(86-02-27,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-26 Joanne Backs: Modified to not put in the defaults for copies,
     lmargin and notify in auto_dprint_arg before printing.  These are now
     personalization options and will be filled in by xmail_print_$submit_file.
     
     85-04-02 Joanne Backs: Deleted call to ioa_ to display user message.  Added
     the call to xmail_print_ so messages when printing would be consistant.
     Also deleted calls to xmail_value_$get since they were only used in message
     and the values are already known in xmail_print_.
  2) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Updated to use latest version (9) of dprint_arg.
  3) change(88-07-07,Blair), approve(88-07-27,MCR7959),
     audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098):
     Check for e_t_$moderr on the print request in case user has no access to
     the print queue.  XServices error_list 139.
                                                   END HISTORY COMMENTS */


xmail_dprint_msgs_: proc (P_mailbox_ptr, P_curr_msgsp);

/* BEGIN DESCRIPTION

history:
   Author unknown.

   Modified 10/25/82 by Dave Schimke to use version 7 dprint_args. 
   
   83-07-05  DJ Schimke: Deleted dcls for unreferenced addr and
   xmail_err_$int_prog_err.

   83-09-15  DJ Schimke: Added the mailfile name to the output
   and to the temporary dprint segment. phx13056

   84-09-27  JG Backs: Modified to use version 8 dprint_args. 

   84-10-31  JG Backs: Added translate function to change spaces to
   underscores in the "mailbox_name" so the segment that is created 
   can be printed.  The call to iox_$attach_name will not accept the 
   spaces, although xmail does allow spaces in mailbox names.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     (P_mailbox_ptr, P_curr_msgsp) ptr;

/* AUTOMATIC */

	dcl     code		 fixed bin (35);
	dcl     dname		 char (168);
	dcl     ename		 char (32);
	dcl     iocb_ptr		 ptr;
	dcl     seg_ptr		 ptr;
	dcl     mailbox_name	 char (32);
	dcl     unused_return_bc	 fixed bin (35);

	dcl     1 auto_dprint_arg	 like dprint_arg;

/* BUILTINS */

	dcl     (addr, after, codeptr, length, null, reverse, rtrim, translate, substr, unspec, verify) builtin;

/* ENTRIES */

	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35));
          dcl     error_table_$moderr    fixed bin(35) ext static;
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     ioa_$ioa_switch	 entry () options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     xmail_display_msgs_$ff entry (ptr, ptr, ptr);
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_list_msgs_$selected entry (ptr, ptr, ptr);
	dcl     xmail_print_$create_seg entry (char (*), ptr, fixed bin (35));
	dcl     xmail_print_$delete_seg entry (ptr, fixed bin (35));
	dcl     xmail_print_$submit_seg entry (ptr, char (*), ptr, fixed bin (35));
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));

/* CONSTANTS */

	dcl     CONSONANTS		 char (32) static init ("BCDFGHJKLMNPQWXZbcdfghjklmnpqwxz") options (constant);
	dcl     LAST_CHAR		 bit (1) aligned init ("1"b) int static options (constant);
	dcl     ME_CHAR		 char (18) init ("xmail_dprint_msgs_") int static options (constant);
	dcl     ME_ENTRY		 entry options (variable) init (xmail_dprint_msgs_);
	dcl     UNUSED_BIT		 bit (1) aligned int static options (constant) init ("0"b);

/* EXTERNAL STATIC */

	dcl     (xmail_err_$no_curr_msgs,
	        xmail_err_$no_hardcopy) fixed bin (35) ext static;

/* CONDITIONS */

	dcl     cleanup		 condition;

/* INCLUDE FILES */

%include terminate_file;
%page;
%include iox_modes;
%page;
%include dprint_arg;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_message;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_data;

/* BEGIN */

	iocb_ptr, seg_ptr = null;

	on condition (cleanup) begin;
		call close_detach_and_destroy (iocb_ptr);
		if seg_ptr ^= null then call xmail_print_$delete_seg (seg_ptr, (0)); /* ignore code */
	     end;

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure.  This is an internal programming error.");

	if P_curr_msgsp = null
	then call xmail_error_$code_first (xmail_err_$no_curr_msgs, ME_CHAR, "i");
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	end;

	curr_msgsp = P_curr_msgsp;
	mailbox_ptr = P_mailbox_ptr;

	if mailbox.mailbox_type = USER_DEFAULT_MAILBOX |
	     mailbox.mailbox_type = OTHER_MAILBOX
	then mailbox_name = minus_suffix (mailbox.mailbox_ename, "mbx");
	else mailbox_name = minus_suffix (mailbox.mailbox_ename, "sv.mbx");

	if substr (mailbox_name, 1, 1) = "!"
	then if length (rtrim (mailbox_name)) = 15
	     then if verify (substr (mailbox_name, 2, 14), CONSONANTS) = 0
		then mailbox_name = "";

/* Translate mailbox_name so it does not have spaces - replace with
   underscores so it can be printed */

	if mailbox_name ^= ""
	then mailbox_name = translate (rtrim (mailbox_name), "_", " ");

	call xmail_print_$create_seg (mailbox_name, seg_ptr, code);
	if code = 0 then call terminate_file_ (seg_ptr, 0, TERM_FILE_TRUNC, code);
	if code = 0 then call hcs_$fs_get_path_name (seg_ptr, dname, (0), ename, code); /* ignore code */
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to prepare file. This is an internal programming error.");

	call iox_$attach_name (unique_chars_ ("0"b), iocb_ptr, "vfile_ " || rtrim (dname) || ">" || (ename), codeptr (ME_ENTRY), code);
	if code = 0 then call iox_$open (iocb_ptr, Stream_output, UNUSED_BIT, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to prepare output switch to file. This is an internal programming error.");

	if mailbox_name ^= ""
	then call ioa_$ioa_switch (iocb_ptr, "Mailfile: ^a^/", mailbox_name);

	if curr_msgs.count > 1
	then do;
	     call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iocb_ptr);
	     call ioa_$ioa_switch (iocb_ptr, "^|");
	end;

	call xmail_display_msgs_$ff (mailbox_ptr, curr_msgsp, iocb_ptr);

	call adjust_bit_count_ ((dname), (ename), LAST_CHAR, unused_return_bc, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to adjust bit count of file. This is an internal programming error.");

	unspec (auto_dprint_arg) = "0"b;
	auto_dprint_arg.version = dprint_arg_version_9;
	auto_dprint_arg.delete = 1;
	auto_dprint_arg.carriage_control = "0"b;
	auto_dprint_arg.line_lth = -1;
	auto_dprint_arg.page_lth = -1;
	auto_dprint_arg.top_label = "";
	auto_dprint_arg.bottom_label = "";
	auto_dprint_arg.form_name = "";
	auto_dprint_arg.chan_stop_path = "";
	auto_dprint_arg.request_type = "printer";
	auto_dprint_arg.defer_until_process_termination = 0;
	auto_dprint_arg.bit_count = unused_return_bc;

	call xmail_print_$submit_seg (seg_ptr, "", addr (auto_dprint_arg), code);
	if code = xmail_err_$no_hardcopy
	then call xmail_error_$code_first (xmail_err_$no_hardcopy, ME_CHAR, "i", "Please specify this information via the ""Personalize Exec Mail"" menu.");
          else if code = error_table_$moderr 
	     then call xmail_error_$code_first (code, ME_CHAR, "q", "^/You do not have access to the requested print queue. ^/See your system administrator.");
	else if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to submit print request. This is internal programming error.");

	call close_detach_and_destroy (iocb_ptr);

	return;

/* INTERNAL PROCEDURES */

close_detach_and_destroy: proc (P_iocb_ptr);

	dcl     P_iocb_ptr		 ptr;

	if P_iocb_ptr ^= null
	then do;
	     call iox_$close (P_iocb_ptr, (0));		/* ignore code */
	     call iox_$detach_iocb (P_iocb_ptr, (0));	/* ignore code */
	     call iox_$destroy_iocb (P_iocb_ptr, (0));	/* ignore code */
	end;

     end close_detach_and_destroy;

minus_suffix: proc (name, suffix) returns (char (*) var);

/* Parameter */

	dcl     name		 char (*);
	dcl     suffix		 char (*);

/* Automatic */

	dcl     reverse_name	 char (length (name)) var;
	dcl     reverse_suffix	 char (length (suffix)) var;

	reverse_name = reverse (rtrim (name));
	reverse_suffix = reverse (rtrim (suffix));

	return (reverse (after (reverse_name, reverse_suffix || ".")));

     end minus_suffix;


    end xmail_dprint_msgs_;




		    xmail_dyn_menu_.pl1             09/02/88  0759.6r w 09/02/88  0749.2       68589



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




/****^  HISTORY COMMENTS:
  1) change(86-01-07,LJAdams), approve(86-04-15,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Added screen headers for General Help Topics screen.
                                                   END HISTORY COMMENTS */


xmail_dyn_menu_: proc ();

/* Author unknown.   

   83-07-05  DJ Schimke: Deleted dcl for unreferenced ME_CHAR.

   83-10-11  DJ Schimke: Added free entry point to free storage used by
   the dynamic menus. This entry should be called by cleanup procedures
   wherever dynamic menus are created.
*/
/* Parameter */

	dcl     P_areap		 ptr;
	dcl     P_choice		 fixed bin;
	dcl     P_code		 fixed bin (35);
	dcl     P_dyn_menup		 ptr;
	dcl     P_dyn_menu_reqp	 ptr;
	dcl     P_fkey		 bit (1) aligned;
	dcl     P_index		 fixed bin;
	dcl     P_names		 (*) char (*) aligned;
	dcl     P_trailer		 char (*);

/* Automatic */

	dcl     area_ptr		 ptr;
	dcl     dyn_menup		 ptr;
	dcl     free_slots_per_menu	 fixed bin;
	dcl     last_menu_num	 fixed bin;
	dcl     menu_no		 fixed bin;
	dcl     n_slots_per_menu	 fixed bin;
	dcl     n_menus		 fixed bin;
	dcl     slots_avail		 fixed bin;
	dcl     slots_needed	 fixed bin;
	dcl     trailer_included	 bit (1) aligned;

/* Based */

	dcl     based_area		 area based (area_ptr);

	dcl     1 dyn_menu		 aligned based (dyn_menup),
		2 nth_menu	 fixed bin,
		2 menu_array	 (0:n_menus - 1 refer (dyn_menu.nth_menu)),
		  3 location	 ptr,
		  3 first_option	 fixed bin,
		  3 option_count	 fixed bin;

/* Entries */

          dcl     ioa_$rsnnl		 entry () options (variable);

/* Static */

	dcl     OPTION_CODES	 (61) char (1) unal static options (constant) init
				 ("1", "2", "3", "4", "5", "6", "7", "8", "9",
				 "a", "b", "c", "d", "e", "f", "g", "h", "i",
				 "j", "k", "l", "m", "n", "o", "p", "q", "r",
				 "s", "t", "u", "v", "w", "x", "y", "z",
				 "A", "B", "C", "D", "E", "F", "G", "H", "I",
				 "J", "K", "L", "M", "N", "O", "P", "Q", "R",
				 "S", "T", "U", "V", "W", "X", "Y", "Z");

/* Builtin */

	dcl     (addr, divide, hbound, null, rtrim) builtin;

%page;
create: entry (P_names, P_dyn_menup, P_dyn_menu_reqp, P_areap, P_code);

	trailer_included = "0"b;
	go to MAIN;

create_w_trailer: entry (P_names, P_trailer, P_dyn_menup, P_dyn_menu_reqp, P_areap, P_code);

	trailer_included = "1"b;

MAIN:

	P_dyn_menup = null;
	dyn_menu_reqp = P_dyn_menu_reqp;
	P_code = 0;

	area_ptr = P_areap;

	slots_avail = 2 * (xmail_windows.bottom.height - 1); /* 2 columns, 1 header, no trailers */
	slots_needed = hbound (P_names, 1);
	n_slots_per_menu = slots_avail;
	if ^trailer_included
	then free_slots_per_menu = slots_avail;
	else free_slots_per_menu = slots_avail - 1;
	n_menus = divide (slots_needed + free_slots_per_menu - 1, free_slots_per_menu, 17, 0);

	allocate dyn_menu in (based_area);

	begin;

	     dcl	   choice_array	      (slots_avail) char (32) varying;
	     dcl	   done_with_names	      bit (1) aligned;
	     dcl	   name_count	      fixed bin;
	     dcl	   header		      (1) char (xmail_windows.bottom.width) varying;
	     dcl     header2                (1) char (xmail_windows.bottom.width) varying;
	     dcl	   option_no	      fixed bin;
	     dcl	   trailer	      (1) char (xmail_windows.bottom.width) varying;

	     dcl	   1 actual_menu_format   aligned like menu_format;
	     dcl	   1 actual_menu_requirements aligned like menu_requirements;

	     dcl	   choices	      (option_no) char (32) varying based (addr (choice_array));

	     actual_menu_format.version = menu_format_version_1;
	     actual_menu_format.max_width = xmail_windows.bottom.width;
	     actual_menu_format.max_height = xmail_windows.bottom.height;
	     actual_menu_format.n_columns = 2;
	     actual_menu_format.center_headers = "1"b;
	     actual_menu_format.center_trailers = "1"b;
	     actual_menu_format.pad = "0"b;
	     actual_menu_format.pad_char = "-";

	     actual_menu_requirements.version = menu_requirements_version_1;

	     trailer = "";

	     name_count = 0;
	     done_with_names = "0"b;

	     do menu_no = 0 to dyn_menu.nth_menu;

		do option_no = 1 to n_slots_per_menu while (^done_with_names);

		     if option_no = n_slots_per_menu & trailer_included
		     then choices (option_no) = P_trailer;
		     else do;
			choices (option_no) = rtrim (P_names (name_count + 1));
			name_count = name_count + 1;
		     end;
		     if name_count = hbound (P_names, 1)
		     then do;
			if trailer_included
			then do;
			     option_no = option_no + 1;
			     choices (option_no) = P_trailer;
			end;
			done_with_names = "1"b;
		     end;
		end;

		option_no = option_no - 1;
		dyn_menu.menu_array (menu_no).option_count = option_no;
		dyn_menu.menu_array (menu_no).first_option = menu_no * n_slots_per_menu + 1;

		if xmail_data.general_help then do;
		   header2 = " General Help Topics ";

		   
		call menu_$create (choices, header2, trailer, addr (actual_menu_format), OPTION_CODES, area_ptr, addr (actual_menu_requirements), dyn_menu.menu_array (menu_no).location, P_code);
		if P_code ^= 0 then return;
		   end;
		else do;
		   call ioa_$rsnnl ("Choices (menu ^d of ^d)", header (1), (0), menu_no + 1, n_menus);
		   actual_menu_format.pad_char = " ";
		call menu_$create (choices, header, trailer, addr (actual_menu_format), OPTION_CODES, area_ptr, addr (actual_menu_requirements), dyn_menu.menu_array (menu_no).location, P_code);
		if P_code ^= 0 then return;
		end;
	     end;					/* do menu_no = ... */

	end;					/* begin */

	if dyn_menu_reqp ^= null
	then do;
	     dyn_menu_req.options_per_menu = slots_avail;
	     dyn_menu_req.options_last_menu = dyn_menu.menu_array (n_menus - 1).option_count;
	     dyn_menu_req.n_menus = n_menus;
	end;

	P_dyn_menup = dyn_menup;

	return;					/* create */
%page;
display: entry (P_dyn_menup, P_index, P_code);

	P_code = 0;
	dyn_menup = P_dyn_menup;

	call menu_$display (xmail_windows.bottom.iocb, dyn_menu.menu_array (P_index).location, P_code);

	return;					/* display */
%page;
free: entry (P_dyn_menup, P_code);

	P_code = 0;
	dyn_menup = P_dyn_menup;

	do menu_no = 0 to dyn_menu.nth_menu while (P_code = 0);
	     call menu_$destroy (dyn_menu.menu_array (menu_no).location, P_code);
	end;
	return;					/* free */
%page;
get_choice: entry (P_dyn_menup, P_index, P_choice, P_fkey, P_code);

	P_code = 0;
	dyn_menup = P_dyn_menup;

	call menu_$get_choice (xmail_windows.bottom.iocb, dyn_menu.menu_array (P_index).location, xmail_data.function_key_data_ptr, P_fkey, P_choice, P_code);

	return;					/* get_choice */

%page;
info: entry (P_dyn_menup, P_dyn_menu_reqp, P_code);

	P_code = 0;
	dyn_menu_reqp = P_dyn_menu_reqp;
	dyn_menup = P_dyn_menup;
	last_menu_num = dyn_menu.nth_menu;

	dyn_menu_req.options_per_menu = dyn_menu.menu_array (0).option_count;
	dyn_menu_req.options_last_menu = dyn_menu.menu_array (last_menu_num).option_count;
	dyn_menu_req.n_menus = last_menu_num + 1;

	return;					/* info */

%page;
%include xmail_windows;
%page;
%include menu_dcls;
%page;
%include xmail_dyn_menu_dcls;
%page;
%include xmail_data;

     end xmail_dyn_menu_;




		    xmail_emacs_ext_main_.lisp      01/12/88  1403.0rew 01/12/88  1330.0      529137



;;; ***********************************************************
;;; *                                                         *
;;; * Copyright, (C) Honeywell Bull Inc., 1987                *
;;; *                                                         *
;;; * Copyright, (C) Honeywell Information Systems Inc., 1982 *
;;; *                                                         *
;;; ***********************************************************

;;; HISTORY COMMENTS:
;;;  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
;;;     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
;;;     85-05-10 Backs, Barstad, Davids, Dixon: Changed calls to replace-field
;;;     so that the name of the field ALWAYS terminates in a : character. This
;;;     prevents complete hose mode when the contents of a previous field contains
;;;     a string which is the same as the current field name minus the colon, i.e.
;;;     the To: field contains a person.project of XXX.Mcc screws things up when
;;;     the cc field is processed.
;;;     86-1-6 C Spitzer: Added check for 0 length reply segment in reply-mode.
;;;  2) change(86-01-07,LJAdams), approve(86-02-26,MCR7358),
;;;     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
;;;     Added change to display hyphens to delimit bottom window in editor.
;;;     Changed help screen formats as per MTB701.
;;;  3) change(86-02-26,Blair), approve(86-02-26,MCR7358),
;;;     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
;;;     Put a command-quit at the end of the code which is executed after a
;;;     reconnect to bring processing back into the edit loop. TR 19420
;;;  4) change(86-06-25,Blair), approve(86-07-15,MCR7447),
;;;     audit(86-07-16,LJAdams), install(86-07-21,MR12.0-1100):
;;;     Change xmail:replace-field to look for header keywords at the start of
;;;     lines only. TR 20269.
;;;  5) change(86-06-26,Blair), approve(86-07-15,MCR7447),
;;;     audit(86-07-16,LJAdams), install(86-07-21,MR12.0-1100):
;;;     Position cursor to end of original during reply.  Error_list #125.
;;;  6) change(86-10-15,Blair), approve(86-10-15,MCR7564),
;;;     audit(86-10-28,RBarstad), install(86-10-29,MR12.0-1201):
;;;     Make the parse-address-list skip over quoted strings so that it can
;;;     correctly determine what is a single address to send to
;;;     xmail_validate_.  Fixes error 129, TR 20591.
;;;  7) change(87-08-10,Blair), approve(87-12-10,MCR7818),
;;;     audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013):
;;;     Add processing for a reply-to field when sending mail.
;;;                                                      END HISTORY COMMENTS

;;;
;;; Notes:
;;;    84-08-09 Davids: Need to investigate which modes are really used
;;;    and remove references to and code for unused modes.
;;;
;;;    84-08-14 JG Backs: Refer to history of 84-08-14. If there are
;;;    no problems after a couple of months, completely delete the 
;;;    commmented out call and the two functions.
;;;
;;; Emacs extension to implement Executive Mail functions.
;;; Richard Mark Soley, July/August 1981
;;; Modified September 1981 RMSoley for bug fixes/small changes.
;;; Modified September/October 1981 RMSoley for key binding changes,
;;;	many changes, support tasking.
;;; Modified November 1981 RMSoley for new reply mode.
;;;
;;; Modified September 21, 1983 R Harvey to merge kills on kill ring 
;;;       for xmail:rubout-word. phx11987
;;;
;;; Modified October 20, 1983 DJ Schimke to add code to xmail:quit-handler so
;;;   hitting the quit key will prompt to be sure the user intends to
;;;   quit. phx13018 Also added a call to xmail_window_manager_$reconnect_test
;;;   so reconnection doesn't look like the BREAK key was hit. phx 13227
;;;   replaced all calls to yesp with xmail:yesp for consistency with the
;;;   mailing list extension.
;;;
;;; Modified February 1, 1984 DJ Schimke to make minibuffer at least 2 lines.
;;;    (3 lines during header error processing)
;;; 
;;; Modified February 6, 1984 DJ Schimke to check all recipient addresses when
;;; entering in EDIT mode (replying or sending defered). phx12960 phx12677
;;; 
;;; To replace the ESC-G (get file) functionallity,
;;; delete every occurence of the string ";*ESC-G*" in this file.
;;;
;;; 84-08-03 Davids: Modified xmail:go-to-beginning-of-buffer to check to see
;;; if it's in a minbuffer and if it is to execute the standard
;;; go-to-beginning-of-buffer command. This prevents a null pointer fault.
;;;
;;; 84-08-06 Davids: Modified xmail:go-to-beginning-of-buffer so that it called
;;; the standard go-to-beginning-of-buffer function if the change-header buffer
;;; is on the screen. If it is on the screen it means that the user is changing
;;; the header and the standard function is the one to be used. Also removed
;;; the *ESC-G* comments which allows the file insertion capability that Dave
;;; implemented. Changed the prompt to include the information that a null
;;; file name would cause an abort.
;;;
;;; 84-08-07 Davids: Added the general-help function. this required loadlib-ing
;;; e_macops_ and e_self_documentor_ as well as adding help text for each
;;; redefined command. Also defined the ESC-^H key sequence. Finally changed
;;; all the instructions output in xmail:instructions to include ESC ? and
;;; removed references to ESC g, which I do not think belonged in the
;;; instructions. The loadlibing of e_macops_ was replaced with the function
;;; definition of display-buffer-as-printout. This was the only function in
;;; e_macops_ that was referenced.
;;;
;;; 84-08-09 Davids: Added code for handling blind carbon copies. This
;;; consisted of duplicating the code for carbon copies.
;;;
;;; 84-08-14 JG Backs: Commented out call to xmail:fill-in-blanks in the
;;; function xmail:get-fields.  This was done to prevent "<None> <None>"
;;; from appearing when cc or bcc was blank in reply mode.  After a few months
;;; of no problem use, the call should be deleted along with the two functions
;;; xmail:fill-in-blanks and xmail:fill-in-one.
;;;
;;; 84-10-15 Davids: Added code to xmail:general-help so that if help is
;;; requested while in the minibuffer, i.e. answering a prompt, the correct set
;;; of requests is displayed. Also so that the summary is automatically 
;;; displayed. This gets around an emacs bug that causes emacs to go into hosed
;;; mode when there is an attempt to get help for a key while in the minibuffer
;;;
;;; 84-11-04 JG Backs: Corrected misspelled word in history section, took out
;;; one of the double references to minibufferp in Global variables, cleaned 
;;; up and rewrote some of the documentation to the user, and shortened part
;;; of the minibuffer-print line to say "ESC t to defer". Audit change.
;;;
;;; 84-11-26 Davids: Added a test to the xmail:refill function so that it
;;; calls xmail:beginning-of-paragraph only if it is not already at the
;;; the beginning of the paragraph. The beginning of paragraph function will
;;; move you to the beginning of the next paragraph if you are at the beginning
;;; of the current paragraph. This fixes TR18523.
;;;
;;; 85-01-04 JG Backs: Added an "or" test in xmail:general-help so that the
;;; full help summary for send-mode is displayed if send-mode or edit-mode
;;; (deferred messages).  Only the first two lines were being displayed in
;;; edit-mode.  Bugfix.
;;;
;;; Load in the necessary include files.
(%include e-macros)  
(%include backquote)

;;; To use in debug mode, remove the semicolon at the beginning of this line:
;(sstatus feature debug)

(declare
  ;; These are functions defined elsewhere in Emacs.
  (*lexpr minibuffer-response xmail:minibuffer-response report-error-noabort
          xmail:quit-handler)
  (*expr e_lap_$rtrim emacs$get_info_ptr error-table eval-lisp-line file-insert
         fill-current-line fill-mode kill-to-beginning-of-line lowercase-ttp
         mark-at-current-point-p minibuffer-clear-all signalquit buffer-kill
         prev-line-command quit-force redisplay-command save-same-file
         search-not-charset-forward set-minibuffer-size user_info_$homedir
         eval:internal exists-file set-permanent-key e_lap_$return-string
         set-the-mark beginning-of-paragraph runoff-fill-region get_pdir_
         end-of-paragraph expand-window-to-whole-screen rdis-choose-echo-linex
         create-new-window-and-go-there find-file-subr 
         at-beginning-of-paragraph substr 
         emacs$set_emacs_return_code loadlib 
         key-prompt get-key-binding get-key-name describe-internal)

;;; Global variables.
  (special xmail:subject-text xmail:cc-text xmail:bcc-text xmail:to-text xmail:reply-to-text
	 xmail:markers xmail:message-mark xmail:header-info xmail:mode
	 xmail:sleep xmail:silent-instructions known-buflist
	 paragraph-definition-type whitespace-charactertbl minibufferp
	 mode-line-hook fill-prefix suppress-minibuffer no-minibuffer-<>
           suppress-remarks quit-on-break buffer-creation-hook
           default-fill-column rdis-splln-mark screenheight selected-window
           message quit-handler-invoked rdis-mbuf-transient-linex
           minibufwindow xmail:reply-segment-bc nuwindows xmail:dashes 
	 DASHES screenlinelen DOUBLEQUOTE)

;;; Validate a single address.
  (defpl1 xmail_validate_$addr "" (char (*)) (return fixed bin (35.)))
;;; Get the user's name.
  (defpl1 user_info_ ""  (return char (22)))
;;; Test for reconnect.
  (defpl1 xmail_window_manager_$reconnect_test "" (return bit (1) aligned)))

(eval-when (eval compile)
	 ;; Force output to the minibuffer.
	 (defun force-minibuffer-print macro (form)
	        `(let ((suppress-minibuffer nil))
		    suppress-minibuffer
		    (minibuffer-print . ,(cdr form))))
	 ;; Macro-defining-macro for mode checking.
	 (defun defmode macro (form)
	        `(defun ,(make_atom (catenate (cadr form) "-mode"))
		      macro (form)
		      '(eq xmail:mode ',(cadr form))))

	 ;; Define the known modes.
	 (defmode send)
;;	 (defmode store)
	 (defmode fwd)
	 (defmode fwd-comment)
	 (defmode reply)
	 (defmode edit)
	 (defmode send-from-file)
	 (defmode prob-rept)
	 )

(defun xmail:setup ()
       (expand-window-to-whole-screen)

       ;;; Set the internal options of Emacs.
       (or (status feature debug)
	 (setq mode-line-hook 'xmail:mode-line	;Empty mode line.
	       paragraph-definition-type 2	;The "right" one.
	       suppress-minibuffer t		;No minibuffer output.
	       no-minibuffer-<> t		;No "<>" after mbuf input.
	       suppress-remarks t		;No Reading/Writing messages.
	       default-fill-column 72.	;Fill column for all buffers.
	       fill-column 72.		;Fill column for this buffer.
	       quit-on-break t		;Quit Emacs on BREAK.
	       quit-handler-invoked nil         ;Not yet
	       buffer-creation-hook 'xmail:turn-on-fill  ;Turn on fill mode.
	       ))

       ;;; Set internal variables to xmail.
       (setq xmail:to-text nil
	   xmail:cc-text nil
	   xmail:bcc-text nil
             xmail:reply-to-text nil
	   xmail:subject-text nil
	   xmail:silent-instructions t
	   xmail:sleep 3
	   xmail:markers nil)

       (setq DASHES "-----------------------------------------------------------------------------------------------------------------------------------------------------------------------")

       ;;; Set these keys for all buffers.
       (mapc '(lambda (x) (set-permanent-key (car x) (cadr x)))
	   '(
	   ("ESC-N"	next-screen)
	   ("ESC-P"	prev-screen)
	   ("^F"		forward-char)
	   ("^B"		backward-char)
	   ("^P"		prev-line-command)
	   ("^N"		next-line-command)
	   ("^Y"		yank)
	   ("CR"		new-line)
	   ("ESC-F"	forward-word)
	   ("ESC-B"	backward-word)
	   ("^K"		kill-lines)
	   ("\177"	rubout-char)
	   (""	          rubout-char) ;backspace
	   ("#"		rubout-char)
	   ("^D"		delete-char)
	   ("@"		kill-to-beginning-of-line)
	   ("ESC-#"	rubout-word)
	   ("ESC-"	rubout-word)
	   ("ESC-^H"	rubout-word)
	   ("ESC-D"	delete-word)
	   ("\"		escape-char)
	   ("ESC-R"	xmail:redisplay-command)
	   ("ESC-Q"	xmail:finished)

	   ("^A"		go-to-beginning-of-line)
	   ("^E"		go-to-end-of-line)
	   ("ESC-<"	xmail:go-to-beginning-of-buffer)
	   ("ESC->"	go-to-end-of-buffer)
	   ("ESC-?"         xmail:general-help)
	   ))

       ;; Load in help package
       ;; This isn't necessary when e_self_documentor_ gets bound with emacs_
       (loadlib 'e_self_documentor_)

       ;; If we are debugging, set ESC-ESC.

       (and (status feature debug)
	  (set-permanent-key "ESC-ESC" 'xmail:debugger)))

;;; Function to create empty mode line.
(defun xmail:mode-line ()
       (setq xmail:dashes (substr DASHES 1 screenlinelen))
       (list  xmail:dashes ""))

;;; ^L: redisplay full screen and print instructions.
(defcom xmail:redisplay-command
        &doc "Clears and then redisplays the text being worked on. The text
will be redisplayed so that the current line is centered in the window."
        (redisplay-command)
        (xmail:instructions))

;;; Turn on fill mode.
(defun xmail:turn-on-fill (n) n (fill-mode))

;;; Main function.  Do housekeeping, call correct mode function.
(defun xmail:start ()
       (xmail:setup)
       (fill-mode)
;;; depending on the size of the user_io window, set the size of the minibuffer
       (cond ((not (< screenheight 13.)) (set-minibuffer-size 5))
	   ((= screenheight 12.) (set-minibuffer-size 4))
	   ((= screenheight 11.) (set-minibuffer-size 3))
	   (t (set-minibuffer-size 2)))
       (setq xmail:mode
	   (make_atom
	     (e_lap_$rtrim
	       (e_lap_$return-string (emacs$get_info_ptr) 0 32.))))
       (or (reply-mode) (edit-mode) (fwd-mode)
	 (fwd-comment-mode) (destroy-buffer-contents))
       (go-to-beginning-of-buffer)
       (or (reply-mode)(edit-mode) (redisplay))
       (go-to-end-of-buffer)
       (or (= (cur-hpos) 0) (reply-mode) (edit-mode) (new-line))
       (setq xmail:silent-instructions t)
       (setq xmail:reply-segment-bc
	   (xmail:get-segment-bc process-dir "view_reply_seg"))
       (cond ((send-mode) (xmail:send))
;;	   ((store-mode) (xmail:store))
	   ((fwd-mode) (xmail:fwd))
	   ((fwd-comment-mode) (xmail:fwd-comment))
	   ((reply-mode) (xmail:reply))
	   ((edit-mode) (xmail:edit))
	   ((send-from-file-mode) (xmail:send-from-file))
	   ((prob-rept-mode) (xmail:problem-report)))
       (setq xmail:silent-instructions nil)
       (or (reply-mode) (edit-mode) (send-from-file-mode)
	 (line-is-blank) (new-line))
       (cond ((fwd-mode) (save-same-file) (xmail:quit-force)))
       (setq xmail:message-mark (set-mark))
       (set-minibuffer-size 3)
       (and (or xmail:subject-text xmail:to-text xmail:cc-text xmail:bcc-text
                xmail:reply-to-text)
	  (set-key "ESC-U"	'xmail:change-header))
       (or (fwd-mode)
	 (set-key "ESC-G"	'xmail:insert-file))

       (cond ((reply-mode)
	     (set-key "ESC-H"  'xmail:page-other-window)
	     (set-key "ESC-L"  'xmail:unpage-other-window)
	     (go-to-end-of-buffer)))

       (set-key "ESC-M"	'xmail:refill)
       (set-key "^B"	'xmail:backward-char)
       (set-key "^P"	'xmail:prev-line-command)
       (set-key "ESC-B"	'xmail:backward-word)
       (set-key "\177"	'xmail:rubout-char)
       (set-key ""	          'xmail:rubout-char) ;backspace
       (set-key "#"		'xmail:rubout-char)
       (set-key "ESC-#"	'xmail:rubout-word)
       (set-key "ESC-\177"	'xmail:rubout-word)
       (set-key "ESC-^H"	'xmail:rubout-word)
       (set-key "ESC-P"	'xmail:prev-screen)
       (xmail:instructions))

;;; Main function for SEND mode.
(defun xmail:send ()
       (set-key "ESC-T"  'xmail:finished-defer)
       (xmail:redisplay-command)
       (setq xmail:subject-text
	   (xmail:get-field "Enter Subject (optional): " "Subject:" "subject" nil t))
       (setq xmail:reply-to-text (e_lap_$rtrim (user_info_)))
       (xmail:insert-field "Reply-To:" "")
       (setq xmail:to-text
	   (xmail:get-field "Enter recipient(s): " "To:" "to" t t))
       (setq xmail:cc-text
	   (xmail:get-field "Enter cc (optional): " "cc:" "cc" t t))
       (setq xmail:bcc-text "")
       (xmail:insert-field "bcc:" "")
       (insert-string "Message:"))

;(defun xmail:store ()
;       (xmail:redisplay-command)
;       (setq xmail:subject-text
;	   (xmail:get-field "Enter Subject (optional): " "Subject:" "subject" nil t))
;       (setq xmail:to-text
;	   (xmail:get-field "Enter recipient(s) (optional): " "To:" "to" t t))
;       (setq xmail:cc-text
;	   (xmail:get-field "Enter cc (optional): " "cc:" "cc" t t))
;       (insert-string "Message:"))

;;; Main function for SEND-FROM-FILE mode.
(defun xmail:send-from-file ()
       (setq xmail:subject-text
	   (xmail:get-field "Enter Subject: " "Subject:" "subject" nil t))
       (setq xmail:to-text
	   (xmail:get-field "Enter recipient(s): " "To:" "to" t nil))
       (setq xmail:cc-text
	   (xmail:get-field "Enter cc: " "cc:" "cc" t t))
       (insert-string "Message:")
       (new-line)
       (save-excursion
         (file-insert (xmail:get-good-file "Get message from file: "))))

;;; Main function for FORWARD-WITH-COMMENT mode.
(defun xmail:fwd-comment ()
       (setq xmail:to-text
	   (xmail:get-field "Forward to: " "To:" "to" t nil))
       (setq fill-column 62.)		;Fill column for comments
       (insert-string "Comment (optional):"))

;;; Main function for REPLY mode.
(defun xmail:reply ()
;;       (setq rdis-splln-mark
;;          (cons
;;	     (cons
;;	       "----- Enter F6 to view previous page of reply, F7 to view next -----"
;;	       (ncons nil))
;;	     0))
       (if (> xmail:reply-segment-bc 0)
	 (let ((this-buffer current-buffer))
	      (create-new-window-and-go-there)
	      (go-to-or-create-buffer this-buffer))
	 (select-other-window)
	 (find-file-subr
	   (catenate (e_lap_$rtrim (get_pdir_)) ">view_reply_seg"))
	 (select-other-window)
	 )
       (go-to-beginning-of-buffer)
       (redisplay)
       (go-to-end-of-buffer)
       (setq xmail:reply-to-text (e_lap_$rtrim (user_info_)))
       (xmail:edit))

;;; Main function for EDIT mode.
(defun xmail:edit ()
       (set-key "ESC-T"  'xmail:finished-defer)
       (xmail:get-fields)
       (next-line)
       (go-to-beginning-of-line))

;;; Main function for FORWARD mode.
(defun xmail:fwd ()
       (setq xmail:to-text
	   (xmail:get-field "Forward to: " "To:" "to" t nil)))

;;; Main function for PROBLEM-REPORT mode.
(defun xmail:problem-report ()
       (insert-string
         "Please describe the Executive Mail problem you are having:"))

;;; Utility routine to get the bit count of a segment
;;;    (use the lsh (left-shift) function to prepare the bit strings to the PL/1
;;;    functions as Lisp passes weird bit strings by default).
(declare
  (defpl1 initiate_file_ ""
	(char (*))			;directory
	(char (*))			;entry
	(bit (36.))			;mode
	(return ptr)			;segment pointer
	(return fixed bin (24.))		;bit count
	(return fixed bin (35.)))		;code
  (defpl1 terminate_file_ ""
	(ptr)				;segment pointer
	(fixed bin (24.))			;bit count
	(bit (36.))			;switches
	(return fixed bin (35.)))		;ignore the returned code
  )

(defun xmail:get-segment-bc (dir entry)
       (prog (initiate-result terminate-result)
	   (setq initiate-result
	         (initiate_file_
		 dir			;containing directory
		 entry			;segment name
		 (lsh 1 35.)))		;read mode (0 bit on)
	   (if (not (= 0 (caddr initiate-result)))   ;3rd arg is the code
	       (return -1))			;some error, cannot get the bc
	   (setq terminate-result
	         (terminate_file_
		 (car initiate-result)	;1st arg is the segment pointer
		 0			;bit count to set
		 (lsh 1 33.)))		;only terminate the segment (bit 2 on)
	   (if (not (= 0 terminate-result))
	       (return -1))
	   (return (cadr initiate-result)))     ;2nd arg is the bit count
       )

;;; These functions replace the normal Emacs functions to make sure
;;; that the user cannot touch the message header.

;;; Replaces ^B command.
(defcom xmail:backward-char &numeric-argument (&repeat)
        &doc "Moves backwards one character in the buffer. Tabs and newline 
characters at the end of lines count as single characters.
$$$ will not allow you to stray backwards into the header."
        (or (mark-at-current-point-p xmail:message-mark)
	  (let ((numarg nil)) (backward-char))))

;;; Replaces ^P command.
(defcom xmail:prev-line-command &numeric-argument (&repeat)
        &doc "Move to previous line of buffer. $$$
will attempt to stay in the same horizontal position. It will not allow
you to stray back into the header."
        (or (mark-on-current-line-p xmail:message-mark)
	  (let ((numarg nil)) (prev-line-command))))

;;; Replaces ESC-B command.
(defcom xmail:backward-word &numeric-argument (&repeat)
        &doc "Moves backwards one word in the buffer.
$$$ will not allow you to stray backwards into the header."
        (let ((numarg nil)) (backward-word))
        (or (point>markp xmail:message-mark)
	  (go-to-mark xmail:message-mark)))

;;; Replaces ESC-< command
(defcom xmail:go-to-beginning-of-buffer &numeric-argument (&reject)
        &doc "Moves back to the beginning of the message - i.e.
to the beginning of the first line after the Message: header. If you are
answering a prompt, the cursor will move to the first character of your
answer."
        (cond (minibufferp (go-to-beginning-of-buffer))
	    ((buffer-on-display-in-window 'change-header) (go-to-beginning-of-buffer))
	    (t (go-to-mark xmail:message-mark))))

;;; Replaces ESC-V command.
(defcom xmail:prev-screen &numeric-argument (&repeat)
        &doc "Displays the previous screen (one back) of
this buffer, and leaves the cursor sitting either at the top of the screen
or immediately after the header, whichever is appropriate. A numeric 
argument (e.g. ESC 5 $$$) will move back that many screens."
        (cond ((mark-on-current-line-p xmail:message-mark))
	    ('else (prev-screen)
		 (or (point>markp xmail:message-mark)
		     (go-to-mark xmail:message-mark)))))

;;; ESC-^V
(defcom xmail:page-other-window
        &doc "Displays the next screen (one forward) of the mail
to which you are replying. A numeric argument
(e.g. ESC 5 $$$) will move forward that many screens."
        &numeric-argument (&pass)
        (let ((origwindow selected-window))
	   (unwind-protect
	     (progn
	       (select-other-window)
	       (if (null numarg)(next-screen)
		 else (if (> numarg 0)(next-screen)
			else (setq numarg (- numarg))
			(prev-screen))))
	     (select-window origwindow))))

;;; -1 ESC-^V.
(defcom xmail:unpage-other-window &numeric-argument (&pass)
        &doc "Displays the previous screen (one backward) of the mail
to which you are replying. A numeric argument
(e.g. ESC 5 $$$) will move backward that many
screens."
        (let ((numarg (- (or numarg 1))))
	   (xmail:page-other-window)))

;;; Replaces \177, # command.
(defcom xmail:rubout-char &numeric-argument (&repeat)
        &doc "Deletes the previous character - i.e. the one to the
left of the cursor. $$$ will not let you delete any of the header."
        (or (mark-at-current-point-p xmail:message-mark)
	  (let ((numarg nil))  (rubout-char))))

(defun defkill macro (form) `(defprop ,(cadr form) ,(caddr form) kills))
(defkill xmail:rubout-word reverse)

;;; Replaces ESC-\177, ESC-# command.
(defcom xmail:rubout-word
        &doc "Deletes the word to the left of the cursor. More specifically
deletes characters backwards until the beginning of the word. 
$$$ will not allow you to delete back into the header. Successive $$$s are
merged and may be retrieved with a single ^Y."
        &numeric-argument (&repeat)
        &negative-function delete-word
        (with-mark here
	         (backward-word)
	         (cond ((point>markp xmail:message-mark))
		     (t
		       (go-to-mark xmail:message-mark)))
	         (kill-forward-to-mark here)
	         (merge-kills-reverse)))

;;; For re-filling a region.
(defcom xmail:refill
        &doc "Fills (reformats) the current paragraph, lining up left margin."
        (save-excursion
	(cond ((not (at-beginning-of-paragraph)) (xmail:beginning-of-paragraph)))
	(set-the-mark)
	(end-of-paragraph)
	(without-saving (runoff-fill-region))))

;;; Go to beginning, but NOT INTO HEADER FIELDS!
(defun xmail:beginning-of-paragraph ()
       (beginning-of-paragraph)
       (or (point>markp xmail:message-mark)
	 (go-to-mark xmail:message-mark)))

;;; For inserting files into the buffer.
(defcom xmail:insert-file
        &doc "Will insert a file
at the current cursor position."
        (save-excursion
	(file-insert (xmail:get-good-file "Get message from file (just press RETURN to abort): ")))
        (xmail:instructions))

;;; Pick up fields from the buffer.
(defun xmail:get-fields ()
       (go-to-beginning-of-buffer)
       (do ((contents "")
	  (field ""))
	 ((or (looking-at "Message:")
;;;	      (looking-at "Comment (optional):")
	      (looking-at "Reply:"))
	  (xmail:interpret-field field contents)
;;;	  (xmail:fill-in-blanks)
	  (redisplay))
	 (cond ((looking-at TAB)
	        (forward-char)
	        (with-mark here
		         (go-to-end-of-line)
		         (setq contents
			     (catenate contents
				     (point-mark-to-string here)))))
	       (t (xmail:interpret-field field contents)
		(with-mark begin
			 (forward-search ":")
			 (setq field (point-mark-to-string begin)))
		(forward-char)
		(with-mark here
			 (go-to-end-of-line)
			 (setq contents (point-mark-to-string here)))))
	 (next-line) (go-to-beginning-of-line)))


;;; Interpret contents of field and setq appropriate variable.
(defun xmail:interpret-field (name contents)
       (setq contents (e_lap_$trim contents))
       (cond ((nullstringp name))
	   ((samepnamep name "To:")
	    (setq xmail:to-text (xmail:correct "to" contents t))
	    (xmail:replace-field "To:" xmail:to-text))
	   ((samepnamep name "Subject:")
	    (setq xmail:subject-text contents)
	    (xmail:replace-field "Subject:" xmail:subject-text))
	   ((samepnamep name "bcc:")
	    (setq xmail:bcc-text (xmail:correct "bcc" contents t))
	    (xmail:replace-field "bcc:" xmail:bcc-text))
             ((samepnamep name "Reply-To:")
              (setq xmail:reply-to-text (xmail:correct "Reply-To" contents t))
              (xmail:replace-field "Reply-To:" xmail:reply-to-text))
	   ((samepnamep name "cc:")
	    (setq xmail:cc-text (xmail:correct "cc" contents t))
	    (xmail:replace-field "cc:" xmail:cc-text))))

;;; Display set of instructions in the minibuffer.
(defun xmail:instructions ()
       (let ((suppress-minibuffer nil)) suppress-minibuffer
	  (cond ((or minibufferp xmail:silent-instructions))
	        ((eq current-buffer 'change-header)
	         (minibuffer-clear-all)
	         (minibuffer-print
		 (cond ((samepnamep (car xmail:header-info) "Subject")
		        "Entering or modifying the ""Subject"" text.")
		       ((samepnamep (car xmail:header-info) "To")
		        "Entering or modifying the ""To"" recipient(s).")
		       ((samepnamep (car xmail:header-info) "bcc")
		        "Entering or modifying the ""bcc"" recipient(s).")
		       ((samepnamep (car xmail:header-info) "Reply-To")
		        "Entering or modifying the ""Reply-To"" recipient(s).")
		       ((samepnamep (car xmail:header-info) "cc")
		        "Entering or modifying the ""cc"" recipient(s).")))
	         (minibuffer-print "Enter ESC ? for help    ESC q when done."))
	        ((fwd-mode)
	         (minibuffer-clear-all)
	         (minibuffer-print "Enter ESC ? for help    ESC q when done.")
	         (minibuffer-print "Enter ESC u to change header."))
	        ((edit-mode)
	         (minibuffer-clear-all)
	         (minibuffer-print "Enter ESC ? for help    ESC q to send     ESC t to defer.")
	         (minibuffer-print "Enter ESC u to enter/change header fields."))
	        ((send-mode)
	         (minibuffer-clear-all)
	         (minibuffer-print "Enter ESC ? for help    ESC q to send     ESC t to defer.")
	         (minibuffer-print "Enter ESC u to enter/change header field."))
	        ((reply-mode)
	         (minibuffer-clear-all)
	         (minibuffer-print "Enter ESC ? for help    ESC q to send reply     ESC t to defer reply.")
	         (minibuffer-print "Enter ESC u to change header."))
	        ((not (or xmail:subject-text xmail:to-text xmail:reply-to-text xmail:cc-text xmail:bcc-text))
	         (minibuffer-clear-all)
	         (minibuffer-print "Enter ESC ? for help    ESC q when done."))
	        (xmail:subject-text
		(minibuffer-clear-all)
		(minibuffer-print "Enter ESC ? for help   ESC q when done.")
		(minibuffer-print "Enter ESC u to change ""Subject"", "
			        """To:"", or ""cc:"""))
	        (xmail:cc-text
		(minibuffer-clear-all)
		(minibuffer-print "Enter ESC ? for help   ESC q when done.")
		(minibuffer-print "Enter ESC u to change "
			        "recipients or cc."))
	        (t
		(minibuffer-clear-all)
		(minibuffer-print "Enter ESC ? for help   ESC q when done.")
		(minibuffer-print "Enter ESC u to change ""To:""."))
	        )))

;;; Get the contents of a header field from the user, checking
;;; for validity if necessary, and giving help if asked for.
(defun xmail:get-field (prompt title printable check? allow-blank)
       (minibuffer-clear-all)
       (do ((ans (xmail:minibuffer-response prompt)
	       (xmail:minibuffer-response prompt)))
	 (())
	 (setq ans (e_lap_$trim ans))
	 (cond ((and (samepnamep (substr ans 1 1) "?")
		   (member printable '("to" "cc" "bcc" "reply-to")))
	        (xmail:help printable))
	       ((not check?) (return (xmail:insert-field title ans)))
	       ((and allow-blank (nullstringp ans))
	        (return (xmail:insert-field title "")))
	       ((nullstringp ans)
	        (force-minibuffer-print
		"At least one recipient required. For help enter ? and RETURN"))
	       (t (return
		  (xmail:insert-field
		    title
		    (xmail:correct printable ans allow-blank)))))))

;;; Check field, gather corrections.
(defun xmail:correct (printable field allow-blank)
       (do ((answers (xmail:parse-address-list field) (cdr answers))
	  (string ""))
	 ((null answers)
	  (xmail:instructions)
	  (cond ((and (not allow-blank) (nullstringp string))
	         (force-minibuffer-print "You must enter at least one """
				   printable ":"" address.")
	         (xmail:correct printable
			    (xmail:minibuffer-response
			      "Please enter address: " NL "")
			    allow-blank))
	        (t string)))
	 (let ((fixed (xmail:correct-one printable
				   (car answers)
				   (or (cdr answers)
				       allow-blank
				       (not (nullstringp string))))))
	      (or (nullstringp fixed)
		(setq string
		      (catenate string
			      (cond ((nullstringp string) "") (t ", "))
			      fixed))))))

;;; Check one address for consistency, get new if necessary.
;;; Added ability to enter > 1 address, with commas.
(defun xmail:correct-one (printable string allow-blank)
       (let ((list (xmail:parse-address-list string)))
	  (cond (list (xmail:solidify
		      (mapcar '(lambda (x) (xmail:single printable
						 x allow-blank))
			    list)))
	        (t (xmail:single printable "" allow-blank)))))

;;; Solidify a list of addresses into a string with commas.
(defun xmail:solidify (list)
       (do ((answer (car list) (cond ((nullstringp (car l)) answer)
			       ((nullstringp answer) (car l))
			       (t (catenate answer ", " (car l)))))
	  (l (cdr list) (cdr l)))
	 ((null l) (or answer ""))))

;;; Check a single address, no commas, for correctness.
(defun xmail:single (printable ans allow-blank)
       (setq ans (e_lap_$trim ans))
       (let ((code (xmail_validate_$addr ans)))
	  (cond ((and allow-blank (nullstringp ans)) ans)
	        ((nullstringp ans) ans)
	        ((zerop code) ans)
	        (t (minibuffer-clear-all)
;;;		 (setq rdis-mbuf-transient-linex (+ 2 (car minibufwindow)))
		 (xmail:set-minibuffer-line 2)
		 (cond ((= code (error-table 'mlsys_et_ 'invalid_address_syntax))
		        (force-minibuffer-print
			"Address incorrectly specified. For help enter ? and RETURN.")
		        (xmail:need-correction printable ans allow-blank))
		       ((= code (error-table 'mlsys_et_ 'no_mailbox))
		        (force-minibuffer-print
			"The name and/or project is not known. For help enter ? and RETURN")
		        (xmail:need-correction printable ans allow-blank))
		       ((= code (error-table 'mlsys_et_ 'mte_not_found))
		        (force-minibuffer-print
			"The address, or mailing list, is not known. For help enter ? and RETURN")
		        (xmail:need-correction printable ans allow-blank))
		       ((= code (error-table 'mlsys_et_ 'no_a_permission))
		        (force-minibuffer-print
			"You cannot send mail to the """ printable ":"" address.")
		        (xmail:need-correction printable ans allow-blank))
		       ((= code (error-table 'xmail_err_ 'mailing_list))
		        (xmail:expand-mailing-list ans))
		       (t (let ((suppress-minibuffer nil))
;;;		      suppress-minibuffer
			     (report-error-noabort code))
			(xmail:need-correction printable ans allow-blank)))))))

(defun xmail:set-minibuffer-line (lineno)
       (setq rdis-mbuf-transient-linex (+ lineno (car minibufwindow))))       

;;; Get new response from user for correction.
(defun xmail:need-correction (printable string blank)
       (xmail:correct-one printable
		      (xmail:get-an-entry printable string)
		      blank))

;;; Get one entry, doing help call if user wants.
(defun xmail:get-an-entry (printable string)
       (let ((prompt
	     (catenate "Please correct this """ printable ":"" address: ")))
	  (do ((in (e_lap_$trim (xmail:minibuffer-response prompt NL string))
		 (e_lap_$trim (xmail:minibuffer-response prompt NL new)))
	       (new string (substr in 2)))
	      ((not (= (index in "?") 1)) in)
	      (xmail:help printable))))

;;; Insert field title and contents into buffer.
(defun xmail:insert-field (title contents)
       (let ((under (- 9. (stringlength title))))
	  (insert-string title)
	  (with-mark
	    end-of-title
	    (insert-string (substr "__________" 1 under))
	    (insert-string " ")
	    (insert-string contents)
	    (do ((fill-prefix "	"))
	        ((not (> (cur-hpos) fill-column)))
	        (setq fill-prefix fill-prefix)
	        (fill-current-line))
	    (cond ((line-is-blank) (kill-to-beginning-of-line))
		(t (new-line)))
	    (save-excursion
	      (go-to-mark end-of-title)
	      (do-times under (delete-char))
	      (insert-string (substr "          " 1 under))
	      (and (nullstringp contents)
		 (xmail:insert-blank-info title)))))
       (or (fwd-mode) (redisplay))
       contents)

;;; Finished entire message; write out and punt if all is OK.
(defcom xmail:finished
        &doc "Sends the mail and returns to the Executive Mail menu."
        (emacs$set_emacs_return_code 0)
        (and minibufferp (command-quit))
        (go-to-mark xmail:message-mark)
        (cond ((fwd-comment-mode)
	     (xmail:remove-markers)
	     (save-same-file)
	     (xmail:quit-force))
	    ((nullstringp xmail:to-text)
	     (and (xmail:yesp "There are no primary recipients.  Quit? ")
		(xmail:exit))
	     (xmail:instructions)
	     (command-quit))
	    ((search-not-charset-forward whitespace-charactertbl)
	     (xmail:remove-markers)
	     (save-same-file)
	     (xmail:quit-force))
	    ((xmail:yesp "There is no message.  Quit? ")
	     (xmail:exit))
	    (t (xmail:instructions)
	       (command-quit))))

(defcom xmail:finished-d-reply
        (emacs$set_emacs_return_code 2)
        (and minibufferp (command-quit))
        (go-to-mark xmail:message-mark)
        (cond ((nullstringp xmail:to-text)
	     (and (xmail:yesp "There are no primary recipients.  Quit? ")
		(xmail:exit))
	     (command-quit))
	    ((search-not-charset-forward whitespace-charactertbl)
	     (xmail:remove-markers)
	     (save-same-file)
	     (xmail:quit-force))
	    ((xmail:yesp "There is no reply.  Quit? ")
	     (xmail:exit))
	    (t (xmail:instructions)
	       (command-quit))))

(defcom xmail:finished-defer
        &doc "Returns to the Executive Mail menu. The mail you were working on
is not sent, it is saved as ""defered mail""."
        (emacs$set_emacs_return_code 1)
        (and minibufferp (command-quit))
        (go-to-mark xmail:message-mark)
        (cond ((search-not-charset-forward whitespace-charactertbl)
	     (xmail:remove-markers)
	     (save-same-file)
	     (xmail:quit-force))
	    ((xmail:yesp "There is no text. Do you wish to quit? ")
	     (xmail:exit))
	    (t (xmail:instructions)
	       (command-quit))))

;;; For giving the user help via describe-key
(defcom xmail:general-help &numeric-argument (&reject)
        &doc "Will prompt you for the command you want help with. Entering
a ""?"" will produce a table of all the valid commands with a very short
description."
        (let  ((suppress-minibuffer nil)) suppress-minibuffer
	    (cond (minibufferp
		 (init-local-displays)
		 (local-display-generator-nnl "(ESC x = press escape key then press x;   BS = BACKSPACE = CTL h;")
		 (local-display-generator-nnl " CTL x = hold CONTROL key down while pressing x)")
		 (local-display-generator-nnl "@:    Erase to Start of Line   CTLf:  Forward Char          ESCBS: Backward")
                     (local-display-generator-nnl "BS:   Backward Erase Char      CTLg:  Exit Help                    Erase Word")
                     (local-display-generator-nnl "CTLa: Start of Line            CTLk:  Erase to End of Line  ESCd:  Erase Word")
                     (local-display-generator-nnl "CTLb: Backward Char            CTLy:  Retrieve Erased Text  ESCf:  Forward Word")
                     (local-display-generator-nnl "CTLd: Erase Char               ESC?:  Editor Help           ESCr:  Redisplay")
                     (local-display-generator-nnl "CTLe: End of Line              ESCb:  Backward Word")
		 (end-local-displays))
		(t
		  (let ((key1 (key-prompt "Enter a key sequence (or ? for summary): ")))
		       (cond
		         ((not (and (= (car key1) 0) (= (car (cdr key1)) 77)))
			(let ((symbol (get-key-binding key1))
			      (description (get-key-name key1)))
			     (describe-internal description symbol
					    (catenate description "           " symbol))))
		         (t
			 (init-local-displays)
			 (local-display-generator-nnl "(ESC x = press escape key then press x;   BS = BACKSPACE = CTL h;")
			 (local-display-generator-nnl " CTL x = hold CONTROL key down while pressing x)")
			 (cond
			   ((buffer-on-display-in-window 'change-header)
		 (local-display-generator-nnl "@: Erase to Start of Line CTLg: Exit Help            ESCb:  Backward Word ")
		 (local-display-generator-nnl "BS: Backward Erase Char   CTLk: Erase to End of Line ESCBS: Backward Erase Word")
		 (local-display-generator-nnl "CTLa: Start of line       CTLp: Previous Line        ESCn:  Next Screen")
		 (local-display-generator-nnl "CTLb: Backward Char       CTLy: Retrieve Erased Text ESCp:  Previous Screen")
		 (local-display-generator-nnl "CTLd: Erase Char          ESC<: Start of Header      ESCq:  Update Header Info")
		 (local-display-generator-nnl "CTLe: End of Line         ESC>: End of Header        ESCr:  Redisplay")
                     (local-display-generator-nnl "CTLf: Forward Char        ESC?: Editor Help"))
			   ((or (send-mode) (edit-mode))
			    (local-display-generator-nnl "@:  Erase to Start of Line  CTLn: Next Line             ESCf: Forward word")
			    (local-display-generator-nnl "BS:   Backward Erase Char   CTLp: Previous Line         ESCg: Get File")
			    (local-display-generator-nnl "CTLa: Start of Line         CTLy: Retrieve Erased Text  ESCm: Adjust Paragraph")
			    (local-display-generator-nnl "CTLb: Backward Char         ESC?: Editor Help           ESCn: Next Screen")
			    (local-display-generator-nnl "CTLd: Erase Char            ESC<: Start of Message      ESCp: Previous Screen")
			    (local-display-generator-nnl "CTLe: End of Line           ESC>: End of Message        ESCq: Send Message")
			    (local-display-generator-nnl "CTLf: Forward Char          ESCb: Backward Word         ESCr: Redisplay")
			    (local-display-generator-nnl "CTLg: Exit Help             ESCBS: Backward Erase Word  ESCt: Defer Message")
			    (local-display-generator-nnl "CTLk: Erase to End of Line  ESCd: Erase Word            ESCu: Change Subject or")
                                  (local-display-generator-nnl "                                                              Recipients"))
			   ((reply-mode)
			    (local-display-generator-nnl "@: Erase to Start of Line   CTLp: Previous Line         ESCh: Next Message Page")
			    (local-display-generator-nnl "BS: Backward Erase Char     CTLy: Retrieve Erased Text  ESCl: Previous Msg Page")
			    (local-display-generator-nnl "CTLa: Start of Line         ESC?: Editor Help           ESCm: Adjust Paragraph")
			    (local-display-generator-nnl "CTLb: Backward Line         ESC<: Start of Reply        ESCn: Next Screen")
			    (local-display-generator-nnl "CTLd: Erase Char            ESC>: End of Reply          ESCp: Previous Screen")
			    (local-display-generator-nnl "CTLe: End of Line           ESCb: Backward Word         ESCq: Send Reply")
			    (local-display-generator-nnl "CTLf: Forward Char          ESCBS: Backward Erase Word  ESCr: Redisplay")
			    (local-display-generator-nnl "CTLg: Exit Help             ESCd: Erase Word            ESCt: Defer Reply")
			    (local-display-generator-nnl "CTLk: Erase to End of Line  ESCf: Forward Word          ESCu: Change Recipients")
			    (local-display-generator-nnl "CTLn: Next Line             ESCg: Get File"))
			   ((fwd-comment-mode)
			    (local-display-generator-nnl "@: Erase to Start of Line   CTLn:  Next Line             ESCf: Forward Word")
			    (local-display-generator-nnl "BS: Backward Erase Char     CTLp:  Previous Line         ESCg: Get File")
			    (local-display-generator-nnl "CTLa: Start of Line         CTLy:  Retrieve Erased Text  ESCm: Adjust Paragraph")
			    (local-display-generator-nnl "CTLb: Backward Char         ESC?:  Editor Help           ESCn: Next Screen")
			    (local-display-generator-nnl "CTLd: Erase Char            ESC<:  Start of Comment      ESCp: Previous Screen")
			    (local-display-generator-nnl "CTLe: End of Line           ESC>:  End of Comment        ESCq: Forward Message")
			    (local-display-generator-nnl "CTLf: Forward Char          ESCb:  Backward Word         ESCr: Redisplay")
			    (local-display-generator-nnl "CTLg: Exit Help             ESCBS: Backward Erase Word   ESCu: Change Recipients")
			    (local-display-generator-nnl "CTLk: Erase to End of Line  ESCd:  Erase Word")))
			 (end-local-displays))))))
	    (xmail:instructions)))

(defun display-buffer-as-printout ()
       (save-excursion
         (init-local-displays)
         (go-to-beginning-of-buffer)
         (do-forever
	 (local-display-generator (curline-as-string))
	 (if (lastlinep) (stop-doing))
	 (next-line))))

;;; Local display help for recipient fields.
(defun xmail:help (which)
       (init-local-displays)
       (mapc
         'local-display-generator-nnl
         (cond ((samepnamep which "bcc")
	 '(
	 "Type the names of people whom you want to receive copies of your"
	 "message. When listing recipients, you can use a user name and"
	 "project (e.g., Smith.Finance), and/or the name of a mailing list"
           "(e.g., managers). Names must be separated by commas. You need"
           "not enter any recipients here. Conclude by typing RETURN (or its "
           "equivalent on your keyboard)."
	 ))
	 ((samepnamep which "cc")
	 '(
	 "Type the names of people whom you want to receive copies of your"
	 "message. When listing recipients, you can use a user name and"
	 "project (e.g., Smith.Finance), and/or the name of a mailing list"
           "(e.g., managers). Names must be separated by commas. You need"
           "not enter any recipients here. Conclude by typing RETURN (or its "
           "equivalent on your keyboard)."
            ))
	 ((samepnamep which "reply-to")
	 '(
           "Type the names of people whom you want to receive a reply to this"
	 "message. When listing recipients, you can use a user name and"
	 "project (e.g., Smith.Finance), and/or the name of a mailing list"
           "(e.g., managers). Names must be separated by commas. You need"
           "not enter any recipients here. If you do not enter any names, any"
           "replies will be sent to you. Conclude by typing RETURN (or its "
           "equivalent on your keyboard)."
            ))
	 ((or (fwd-mode) (fwd-comment-mode))
	  '(
	 "Type the names of people whom you want to receive copies of your"
	 "message. When listing recipients, you can use a user name and"
	 "project (e.g., Smith.Finance), and/or the name of a mailing list"
           "(e.g., managers). Names must be separated by commas. You must"
           "enter at least one recipient here. Conclude by typing RETURN (or"
	 "its equivalent on your keyboard)."
	  ))
	  (t
	  '(
	 "Type the names of people whom you want to receive copies of your"
	 "message. When listing recipients, you can use a user name and"
	 "project (e.g., Smith.Finance), and/or the name of a mailing list"
           "(e.g., managers). Names must be separated by commas. You must"
           "enter at least one recipient here if you wish to send the message."
           "Conclude by typing RETURN (or its equivalent on your keyboard)."
	  ))
	  ))
       (end-local-displays))

;;; Get a filename of a file that exists and can be read.
(defun xmail:get-good-file (prompt)
       (do ((name (xmail:minibuffer-response prompt)
	        (xmail:minibuffer-response prompt)))
	 ((xmail:good-file? name) name)))

;;; Check a file for validity: can we read it?
(defun xmail:good-file? (name)
       (let ((suppress-minibuffer nil))
	  suppress-minibuffer
	  (setq name (e_lap_$trim name))
	  (cond ((nullstringp name)
	         (minibuffer-print "Aborting file read.")
	         (sleep xmail:sleep)
	         (xmail:instructions)
	         (command-quit)))
	  (let ((exists? (catch (exists-file name 4) pgazonga)))
	       (cond ((null exists?)
		    (minibuffer-print "File not found.")
		    (ring-tty-bell)
		    nil)
		   ((atom exists?) nil)
		   (t t)))))

;;; Make change prompt.
(defun xmail:make-prompt ()
       (let ((string ""))
	  (and xmail:subject-text (setq string (catenate string "subj,")))
	  (and xmail:to-text (setq string (catenate string "to,")))
	  (and xmail:cc-text (setq string (catenate string "cc,")))
	  (and xmail:bcc-text (setq string (catenate string "bcc,")))
            (and xmail:reply-to-text (setq string (catenate string "reply-to,")))
	  (cond ((nullstringp string) (command-quit))
	        (t (catenate "What do you wish to modify? ("
			 (substr string 1 (1- (stringlength string)))
			 "): ")))))

;;; Prompt for which field wants to be changed, parse answer.
(defun xmail:which-field (prompt)
       (cond ((zerop (index prompt ",")) (substr prompt 30. 1))
	   (t (do ((ans (xmail:minibuffer-response prompt)
		      (xmail:minibuffer-response prompt)))
		(())
		(setq ans (e_lap_$trim ans))
		(cond ((nullstringp ans)
		       (xmail:instructions)
		       (command-quit)))
		(setq ans (substr (lowercase-ttp ans) 1 1))
		(and (or (and (samepnamep ans "s") xmail:subject-text)
		         (and (samepnamep ans "c") xmail:cc-text)
		         (and (samepnamep ans "b") xmail:bcc-text)
		         (and (samepnamep ans "r") xmail:reply-to-text)
		         (and (samepnamep ans "t") xmail:to-text))
		     (return ans))
		(force-minibuffer-print
		  "Incorrect entry. Try again or enter RETURN to stop."
		  )))))

;;; Top level function for changing a header field.
(defcom xmail:change-header
        &doc "This command allows you to change header information, i.e. the
subject, to, reply-to, cc, and bcc fields."
        (let ((which (xmail:which-field (xmail:make-prompt))))
	   (go-to-mark xmail:message-mark)
	   (go-to-or-create-buffer 'change-header)
	   (cond ((samepnamep which "s")
		(xmail:header "Subject" xmail:subject-text t))
	         ((samepnamep which "t")
;;		(xmail:header "To" xmail:to-text (reply-mode)))
		(xmail:header "To" xmail:to-text t))
	         ((samepnamep which "b")
		(xmail:header "bcc" xmail:bcc-text t))
	         ((samepnamep which "r")
		(xmail:header "Reply-To" xmail:reply-to-text t))
	         ((samepnamep which "c")
		(xmail:header "cc" xmail:cc-text t)))))

;;; Prepare header-editing buffer for changing.
(defun xmail:header (name old allow-blank)
       (destroy-buffer-contents)
       (insert-string old)
       (go-to-beginning-of-buffer)
       (setq xmail:header-info (cons name allow-blank))
       (xmail:instructions)
       (set-key "ESC-Q" 'xmail:finish-new-header))

;;; Finished editing header field.  Clean up and install.
(defcom xmail:finish-new-header
        &doc "Finishes the update of header and returns to message."
        (and minibufferp (command-quit))
        (go-to-beginning-of-buffer)
        (do () ((lastlinep))
	  (go-to-end-of-line)
            (insert-char ",")
	  (delete-char))
        (let ((name (car xmail:header-info))
	    (blank? (cdr xmail:header-info))
	    (contents (e_lap_$trim (curbuf-as-string))))
	   (cond ((samepnamep name "Subject"))
	         ((and blank? (nullstringp contents)))
	         ((nullstringp contents)
		(force-minibuffer-print
		  "At least one recipient must be specified.")
		(command-quit))
	         (t (minibuffer-clear-all)
		  (rdis-choose-echo-linex)
		  (setq contents
		        (xmail:correct (cond ((samepnamep name "To") "to")
				         ((samepnamep name "Reply-To") "reply-to")
				         ((samepnamep name "bcc") "bcc")
				         (t "cc"))
				   contents blank?))))
	   (cond ((samepnamep name "Subject") (setq xmail:subject-text contents))
	         ((samepnamep name "To") (setq xmail:to-text contents))
	         ((samepnamep name "bcc") (setq xmail:bcc-text contents))
	         ((samepnamep name "Reply-To") (setq xmail:reply-to-text contents))
	         ((samepnamep name "cc") (setq xmail:cc-text contents)))
	   (go-to-buffer previous-buffer)
	   (save-excursion
	     (xmail:replace-field (catenate name ":") contents)
	     (xmail:instructions))))

;;;Replace the title and contents of a field in the buffer.
(defun xmail:replace-field (title contents)
         (go-to-beginning-of-buffer)
         (forward-search title)
         (go-to-beginning-of-line)
         (do () (())
	   (cond ((looking-at title)
		(return t))
	         (t (next-line)
		  (forward-search title)
		  (go-to-beginning-of-line))))
	   
         (with-mark
	 here
	 (next-line)
	 (do () (())
	     (cond ((mark-on-current-line-p xmail:message-mark)
		  (go-to-beginning-of-line)
		  (backward-char) (insert-string NL)
		  (return t))
		 ((not (looking-at TAB)) (return t))
		 (t (next-line))))
	 (without-saving (wipe-point-mark here)))
         (xmail:insert-field title contents))









;;; Parse address list string into a list of addresses.
(defun xmail:parse-address-list (string)
       (mapcar
         'e_lap_$trim
         (do ((string string)
	    (l ())
	    (append "")
	    (inparen nil))
	   ((nullstringp string)
	    (nreverse (cond ((nullstringp append) l)
			(t (cons append l)))))
	   (let ((comma (index string ","))
	         (quotemark (index string DOUBLEQUOTE))
	         (paren (index string "("))
	         (closeparen (index string ")")))
	        (cond
		((and (not (zerop quotemark)) (< quotemark comma) (or(eq paren 0) (< quotemark paren))(or (eq closeparen 0)(< quotemark closeparen)))
		 (let ((closequote (+ (index (substr string (1+ quotemark))
					   DOUBLEQUOTE) quotemark)))
     		      (cond ((zerop closequote)
			   (setq l (cons (catenate append string) l)
			        string ""
			        append ""))
			  (t (setq append (catenate append (substr string 1 closequote))
				 string (substr string (1+ closequote))
				 ) ))))

		((zerop comma)
		 (setq l (cons (catenate append string) l)
		       append ""
		       string ""))

		((and (not inparen) (or (zerop paren) (< comma paren)))
		 (if (> comma 1)
		     (setq l (cons (catenate append (substr string 1 (1- comma))) l)
			 append ""
			 string (substr string (1+ comma)))
		     else (setq l (cons append l)
		                append ""
			      string (substr string (1+ comma)))))

		(t (cond ((zerop closeparen)
			(setq l (cons (catenate append string) l)
			     string ""
			     append ""))

		         ((not inparen)
			(if (and (> quotemark 0)(< quotemark closeparen))
			    (setq append (catenate append (substr string 1 (1- quotemark)))
				string (substr string quotemark)
				inparen t)
			    else
			    (setq append (catenate append (substr string 1 closeparen))
				string (substr string (1+ closeparen))
				inparen nil)) )

		         (t (setq append (catenate append (substr string 1 closeparen))
			        string (substr string (1+ closeparen))
			        inparen nil)))
		 )))))))
		     

;;; Returns full pathname of mailing list from mailing list name.
(defun xmail:mailing-list-path (name)
       (catenate (e_lap_$rtrim (user_info_$homedir)) ">"
	       (let ((name (status uname)))
		  (substr name 1 (1- (index name ".")))) ".mlsys>"
	       (e_lap_$rtrim name) ".mls"))

;;; Inserts the contents of a mailing list.
(defun xmail:expand-mailing-list (name)
       (let ((string (xmail:expand-mailing-list-internal name)))
	  (let ((sl (stringlength string)))
	       (cond ((zerop sl) string)
		   ((samepnamep (substr string (1- sl) 2) ", ")
		    (substr string 1 (- sl 2)))
		   (t string)))))
;;; Expands mailing list into standard mlsys address form.
;;;(defun xmail:expand-mailing-list (name)
;;;       (catenate "{list " (xmail:mailing-list-path name) "}"))

(defun xmail:expand-mailing-list-internal (name)
       (without-modifying
         (with-mark
	 begin
	 (file-insert (xmail:mailing-list-path name))
	 (with-mark
	   end
	   (go-to-mark begin)
	   (do () ((mark-on-current-line-p end))
	       (go-to-end-of-line)
	       (insert-string ", ")
	       (delete-char))
	   (go-to-mark end)
	   (prog1 (point-mark-to-string begin)
		(without-saving (wipe-point-mark begin)))))))

;;; Insert a string at point, remember it's there for remove-markers.
(defun xmail:insert-marker (string)
       (setq xmail:markers
	   (cons (list (set-mark) string (stringlength string))
	         xmail:markers))
       (insert-string string))

;;; Remove all such markers from the buffer.
(defun xmail:remove-markers ()
       (save-excursion
         (mapc 'xmail:remove-one-marker xmail:markers)
         (setq xmail:markers ())))

;;; Remove a single marker from the buffer.
(defun xmail:remove-one-marker (mark)
       (go-to-mark (car mark))
       (and (looking-at (cadr mark))
	  (do-times (caddr mark) (delete-char)))
       (release-mark (car mark)))

;;; Insert a marker saying that field is blank.
(defun xmail:insert-blank-info (title)
       (let ((insert
	     (cond ((samepnamep title "Subject:") "<No Subject>")
		 ((samepnamep title "To:") "<None>")
		 ((or (and (samepnamep title "To:") (reply-mode))
		      (samepnamep title "cc:") (samepnamep title "bcc:")) "<None>")
		 ((samepnamep title "Reply-To:") (catenate "<" (e_lap_$rtrim (user_info_)) ">"))
		 (t nil))))
	  (cond ((null insert))
	        ((edit-mode) (reply-mode)
	         (xmail:insert-marker insert))
	        (t (xmail:insert-marker (catenate " " insert))))))

;;; Fill in blanks when starting up EDIT mode.
(defun xmail:fill-in-blanks ()
       (and xmail:subject-text (nullstringp xmail:subject-text)
	  (xmail:fill-in-one "Subject:"))
       (and xmail:to-text (nullstringp xmail:to-text)
	  (xmail:fill-in-one "To:"))
       (and xmail:bcc-text (nullstringp xmail:bcc-text)
	  (xmail:fill-in-one "bcc:"))
       (and xmail:cc-text (nullstringp xmail:cc-text)
	  (xmail:fill-in-one "cc:")))

;;; Fix up one blank field.
(defun xmail:fill-in-one (title)
       (save-excursion
         (go-to-beginning-of-buffer)
         (forward-search title)
         (go-to-end-of-line)
         (xmail:insert-blank-info title)))

(defun xmail:minibuffer-response lexpr
       (prog1 (apply 'minibuffer-response (listify lexpr))
	    (xmail:set-minibuffer-line 1)
;;;	    (setq rdis-mbuf-transient-linex (+ 1 (car minibufwindow)))
))

;;; These three little horrible things make sure that all XMAIL buffers
;;; are flushed so that tasking Emacs will not encounter them again.

;;; This one handles plain old ESC Q.
(defun xmail:quit-force ()
       (xmail:hidey-hole-trick)
       (quit-force))

;;;This one handles normal exit via ESC Q
(defun xmail:exit ()
       (xmail:hidey-hole-trick)		;normal exit
       (signalquit))

;;; This one handles the BREAK key.
(defun xmail:quit-handler arg arg
       (cond (quit-handler-invoked)		;are we recursing?
	   ((not (zerop (xmail_window_manager_$reconnect_test)))
	    (xmail:redisplay-command)
	    (command-quit))	;reconnect
	   (t (cond (buffer-modified-flag	;break key
		    (setq quit-handler-invoked t)  ;prevent recursion
		    (cond ((xmail:yesp "Any pending work will be lost. Do you really want to quit?  ")
			 (xmail:hidey-hole-trick)	;yes, quit
			 (signalquit))
			(t (xmail:instructions)  ;no, not quitting
			   (setq quit-handler-invoked nil)
			   (command-quit))))
		  (t (signalquit))))))	     ;buffer not changed, quit	      

;;; This is the guy that really does the trick.
(defun xmail:hidey-hole-trick ()
       (or minibufferp
	 (go-to-or-create-buffer '|_<XMAIL_HIDEY_HOLE>_|))
       (do ((buffers known-buflist (cdr buffers)))
	 ((null buffers))
	 (or (and (eq current-buffer (car buffers))
		(not minibufferp))
	     (buffer-kill (car buffers)))))

;;; And this little piggy went to market.
(defun xmail:go-to-market ()
       (sstatus interrupt 16. 'xmail:quit-handler)
       (cond ((status feature debug)
	    (xmail:setup)
	    (minibuffer-print "Debug: (xmail:start) to start."))
	   (t (xmail:start))))

(defun xmail:yesp (prompt)
       (prog (response ret-value)
	   (minibuffer-clear-all)
	   (xmail:set-minibuffer-line 1)
;;;          (setq rdis-mbuf-transient-linex (+ 1 (car minibufwindow)))
	   (do-forever
	     (setq response (minibuf-response (catenate prompt "  ") NL))
	     (cond ((or (samepnamep response "yes")
		      (samepnamep response "y"))
		  (setq ret-value t)(stop-doing))
		 ((or (samepnamep response "no")
		      (samepnamep response "n"))
		  (setq ret-value nil)(stop-doing))
		 (t (force-minibuffer-print "Please answer ""yes"" or ""no"".")
		    (ring-tty-bell))))
	   (minibuffer-clear-all)
	   (return ret-value)))

;;; Debugging function.
(defcom xmail:debugger
        (minibuffer-print
	(eval
	  (read-from-string (minibuffer-response "XMAIL DBG> ")))))

;;; Patch decimal-rep, which is in e_macops_ (should be in e_basic_)
(defun decimal-rep (x)
       (let ((ibase 10.) (base 10.) (*nopoint t))
	  (maknam (exploden x))))

;;; Start the extension.
(xmail:go-to-market)




		    xmail_emacs_ext_mlist_.lisp     08/20/86  2313.4r w 08/20/86  2245.0      133731



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

;;; HISTORY COMMENTS:
;;;  1) change(86-01-07,LJAdams), approve(86-03-19,MCR7358),
;;;     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
;;;     Added change to display hyphens to delimit bottom window in editor.
;;;     Changed help screen formats as per MTB701.
;;;                                                      END HISTORY COMMENTS


;;;
;;; Author unknown
;;; Modified September 21, 1983 DJ Schimke to fix bad placement of error 
;;;   message in xmail:yesp when other than a valid yes/no response was 
;;;   given. phx 15964
;;;
;;; Modified October 20, 1983 DJ Schimke to add xmail:quit-handler so
;;;   hitting the quit key will prompt to be sure the user intends to
;;;   quit. phx13018 Also added a call to xmail_window_manager_$reconnect_test
;;;   so reconnection doesn't look like the BREAK key was hit. phx 13227
;;;
;;; 84-08-06 Davids: Added the ESC-< and ESC-> requests.
;;;
;;; 84-08-07 Davids: Added the ESC-? command. This required also adding the
;;; display-buffer-as-printout function and loadlib-ing the e_self_documentor_.
;;; help text for xmail:find-error, xmail:quit, and xmail-help were also added.
;;; ESC-<backspace> was also defined as rubout-word.
;;;
;;; 84-11-04 JG Backs: Deleted the commented out "loadlib 'e_macops_" entry
;;; because it was replaced by the display-buffer-as-printout function as
;;; mentioned in 84-08-07 history.  Also cleaned up the documentation for
;;; xmail:help and xmail:quit.  Audit change.

(%include e-macros)

(declare (special
           pop-up-windows
	 xmail-error-info-set
	 xmail-incorrect-line-list
	 xmail-mlist-suffix
	 xmail-code
           quit-handler-invoked
           test-str1))

(declare
  (*lexpr xmail:quit-handler)
  (*expr error-table kill-to-beginning-of-line minibuffer-clear-all
         quit-force save-same-file signalquit redisplay-command
         key-prompt get-key-binding get-key-name describe-internal))

(declare (defpl1 xmail_validate_$addr ""
	       (char(*)) (return (setq xmail-code) fixed bin(35.))))
;;; Test for reconnect.
(declare (defpl1 xmail_window_manager_$reconnect_test ""
	       (return bit (1) aligned)))

(setq rdis-splln-mark
      (cons
        (cons
	""
	(ncons nil))
        0))

(setq mode-line-hook 'xmail:mode-line)
(setq quit-handler-invoked nil)

(set-permanent-key "ESC-U"     'xmail:find-error)

(set-permanent-key "^F"	'forward-char)
(set-permanent-key "^B"	'backward-char)
(set-permanent-key "^P"	'prev-line-command)
(set-permanent-key "^N"	'next-line-command)
(set-permanent-key "^A"       'go-to-beginning-of-line)
(set-permanent-key "^E"       'go-to-end-of-line)
(set-permanent-key "ESC-N"    'next-screen)
(set-permanent-key "ESC-P"    'prev-screen)
(set-permanent-key "CR"	'new-line)
(set-permanent-key "ESC-F"	'forward-word)
(set-permanent-key "ESC-B"	'backward-word)
(set-permanent-key "^K"	'kill-lines)
(set-permanent-key "^Y"	'yank)
(set-permanent-key "\177"	'rubout-char)
(set-permanent-key ""	'rubout-char)  ;backspace
(set-permanent-key "#"	'rubout-char)
(set-permanent-key "^D"	'delete-char)
(set-permanent-key "@"	'kill-to-beginning-of-line)
(set-permanent-key "ESC-#"	'rubout-word)
(set-permanent-key "ESC-"	'rubout-word)
(set-permanent-key "ESC-"     'rubout-word)
(set-permanent-key "ESC-D"	'delete-word)
(set-permanent-key "\"	'escape-char)
(set-permanent-key "ESC-<"    'go-to-beginning-of-buffer)
(set-permanent-key "ESC->"    'go-to-end-of-buffer)
(set-permanent-key "ESC-R"	'redisplay-command)
(set-permanent-key "ESC-Q"	'xmail:quit)
(set-permanent-key "ESC-?"    'xmail:help)

       ;; Load in help package
       ;; This isn't necessary when e_self_documentor_ gets bound with emacs_
       (loadlib 'e_self_documentor_)


(defun xmail:start ()
       (sstatus interrupt 16. 'xmail:quit-handler)
       (setq xmail-mlist-suffix "mls")
       (setq xmail-incorrect-line-list nil)
       (setq xmail-error-info-set nil)
       (xmail:set-info-window))

(defun xmail:mode-line ()
       (list
         (catenate "Mailing list being edited:  <"
	         (or
		 (and (null fpathname) "None")
		 (xmail:get-ename-minus-suffix fpathname xmail-mlist-suffix))
	         ">   ---   Type ESC q to quit")))

(defun xmail:set-info-window ()
       (let ((temp-buf-value current-buffer))
	  (setq pop-up-windows t)
	  (select-buffer-window 'xmail-info 1.)
	  (without-modifying (insert-string "---Please Type One Address Per Line---"))
	  (setq pop-up-windows nil)
	  (find-buffer-in-window temp-buf-value)))

(defun xmail:set-error-info ()
       (if (not xmail-error-info-set)
	 (let ((temp-buf-value current-buffer))
	      (find-buffer-in-window 'xmail-info)
	      (without-modifying
	        (insert-string (catenate NL "---To find errors, type ESC u---")))
	      (find-buffer-in-window temp-buf-value))
	 (setq xmail-error-info-set t)))

(defun xmail:reset-error-info ()
       (if xmail-error-info-set
	 (let ((temp-buf-value current-buffer))
	      (find-buffer-in-window 'xmail-info)
	      (without-modifying
	        (kill-to-beginning-of-line)
	        (rubout-char))
	      (find-buffer-in-window temp-buf-value))
	 (setq xmail-error-info-set nil)))

(defcom xmail:quit ()
       &doc "This will verify the addresses in the mailing list and, if there
are no errors, it will write out the list and return to the menu. If there are
errors you will be prompted to see if you still want to quit. If you respond
with no, you can use the ESC u command to locate the addresses that could
not be verified."
       (go-to-end-of-buffer)
       (go-to-beginning-of-line)
       (delete-white-sides)
       (do-forever
         (if (at-beginning-of-buffer) (stop-doing))
         (prev-line)
         (delete-white-sides)
         (if (eolp) (delete-char)))
       (if (empty-buffer-p current-buffer) (signalquit))
;;	 (if (xmail:yesp "This mailing list is empty.  Do you still wish to quit?")

;;	     (signalquit)))
;;	     (quit-force)))
       (xmail:minibuffer-print "Verifying addresses ...")
       (setq xmail-incorrect-line-list (xmail:mark-incorrect-lines))
       (if (null xmail-incorrect-line-list)
	 (xmail:minibuffer-print "Verified.")
	 (save-same-file)
	 (quit-force)
	 else
	 (if (xmail:yesp "One or more addresses cannot be verified.  Do you still want to quit?")
	     (signalquit)
;;	     (quit-force)
	     else
	     (xmail:set-error-info))))

(defun xmail:mark-incorrect-lines ()
       (prog (error-list error-code error-msg)
	   (if (empty-buffer-p current-buffer)
	       (return nil))
	   (setq error-list nil)
	   (save-excursion
	     (go-to-beginning-of-buffer)
	     (do-forever
	       (setq error-code (xmail:error-on-current-line))
	       (cond
	         ((= error-code (error-table 'xmail_err_ 'mailing_list))
		(setq error-msg "An address in a mailing list cannot be the name of another mailing list."))
	         ((= error-code (error-table 'xmail_err_ 'bad_mailing_list))
		(setq error-msg "An address in a mailing list cannot be the name of another mailing list."))
	         ((= error-code (error-table 'mlsys_et_ 'invalid_address_syntax))
		(setq error-msg "This address is incorrectly specified."))
	         ((= error-code (error-table 'mlsys_et_ 'no_mailbox))
		(setq error-msg "There is no local mailbox corresponding to this address."))
	         ((= error-code (error-table 'mlsys_et_ 'no_a_permission))
                    (setq error-msg "You have not been given access to the mailbox corresponding to this address."))
	         ((= error-code (error-table 'mlsys_et_ 'duplicate_address))
		(setq error-msg "This address is duplicated in this mailing list."))
	         ((not (= error-code 0))
		(setq error-code (error-table 'xmail_err_ 'unrecognizable_addr))
		(setq error-msg "This line appears to be unrecognizable as an address.")))
	       (if (not (= error-code 0))
		 (setq error-list (xmail:add-to-list error-list (cons (set-mark) error-msg))))
	       (if (lastlinep)
		 (stop-doing)
		 else
		 (next-line))))
	   (return error-list)))

(defun xmail:error-on-current-line ()
       (cond
         ((line-is-blank) 0)
         (t (save-excursion
	    (go-to-end-of-line)
	    (delete-white-sides)
	    (go-to-beginning-of-line)
	    (delete-white-sides)
	    (let ((test-str (with-mark m
				 (go-to-end-of-line)
				 (point-mark-to-string m))))
	         (xmail_validate_$addr test-str)
	         (if (= xmail-code 0)
		   (go-to-beginning-of-line)
		   (if (reverse-search test-str)
		       (go-to-end-of-line)
		       (delete-white-sides)
		       (go-to-beginning-of-line)
		       (delete-white-sides)
		       (setq test-str1 (with-mark n 
			          (go-to-end-of-line)
				(point-mark-to-string n)))
		       (if (samepnamep test-str test-str1)
		       (setq xmail-code (error-table 'mlsys_et_ 'duplicate_address)))
		       else
		       (go-to-end-of-line)
		       (if (forward-search test-str)
		       (go-to-end-of-line)
		       (delete-white-sides)
		       (go-to-beginning-of-line)
		       (delete-white-sides)
		       (setq test-str1 (with-mark n 
			          (go-to-end-of-line)
				(point-mark-to-string n)))
		       (if (samepnamep test-str test-str1)
			 (setq xmail-code (error-table 'mlsys_et_ 'duplicate_address))))))))
	  xmail-code)))

(defun xmail:add-to-list (temp-list thing)
       (prog ()
	   (if (null temp-list)
	       (return (ncons thing)))
	   (if (null (cdr temp-list))
	       (return (rplacd temp-list (ncons thing))))
	   (return (cons (car temp-list) (xmail:add-to-list (cdr temp-list) thing)))))

(defcom xmail:find-error ()
       &doc "This will position the cursor to the start of the next line with
an address that could not be verified. This may be done only after the
addresses have been verified via the ESC q command."
       (do-forever				;do until we find an error
         (if (null xmail-incorrect-line-list)
	   (xmail:minibuffer-print "<No more errors>")
	   (xmail:reset-error-info)
	   (stop-doing)
	   else
	   (let ((line-in-error (caar xmail-incorrect-line-list))
	         (error-msg (cdar xmail-incorrect-line-list))
	         (error-code 0))
	        (setq xmail-incorrect-line-list (cdr xmail-incorrect-line-list))
	        (go-to-mark line-in-error)
	        (setq error-code (xmail:error-on-current-line))
	        (if (not (= error-code 0))	;we found our error
		  (release-mark line-in-error)
		  (xmail:minibuffer-print error-msg)
		  (ring-tty-bell)
		  (stop-doing))))))

(defun xmail:get-ename-minus-suffix (partial-pname suffix)
       (prog (i ename)
	   (do-forever
	     (if (or (null partial-pname) (samepnamep partial-pname ""))
	         (setq ename nil)
	         (stop-doing))
	     (setq i (index partial-pname ">"))
	     (if (= i 0)
	         (setq i (index partial-pname (catenate "." suffix)))
	         (if (= i 0)
		   (setq ename partial-pname)
		   (stop-doing)
		   else
		   (setq ename (substr partial-pname 1 (1- i)))
		   (stop-doing))
	         else
	         (setq partial-pname (substr partial-pname (1+ i)))))
	   (return ename)))

(defun xmail:yesp (prompt)
       (prog (response ret-value)
	   (minibuffer-clear-all)
	   (do-forever
	     (setq response (minibuf-response (catenate prompt "  ") NL))
	     (minibuffer-print "")
	     (cond ((or (samepnamep response "yes")
		      (samepnamep response "y"))
		  (setq ret-value t)(stop-doing))
		 ((or (samepnamep response "no")
		      (samepnamep response "n"))
		  (setq ret-value nil)(stop-doing))
		 (t (minibuffer-print "Please answer ""yes"" or ""no""."))))
	   (minibuffer-clear-all)
	   (return ret-value)))

(defun xmail:minibuffer-print (str)
       (minibuffer-clear-all)
       (minibuffer-print str))

;;; This handles the BREAK key and reconnection.
(defun xmail:quit-handler arg arg
       (cond (quit-handler-invoked)		     ;are we recursing?
	   ((not (zerop (xmail_window_manager_$reconnect_test)))
	    (redisplay-command))	               ;reconnect
	   (t (cond (buffer-modified-flag	     ;break key
		    (setq quit-handler-invoked t)  ;prevent recursion
		    (cond ((xmail:yesp "Any pending work will be lost. Do you really want to quit?  ")
			 (signalquit))	     ;yes, quit
			(t (setq quit-handler-invoked nil) ;no, not quitting
			   (command-quit))))
		  (t (signalquit))))))	     ;buffer not changed, quit

;;; For giving the user help via describe-key
(defcom xmail:help &numeric-argument (&reject)
        &doc "Allows you to get an explanation of a command.  Entering
a ""?"" will produce a table of all the valid commands with a very short
description."
        (let  ((suppress-minibuffer nil)) suppress-minibuffer
	    (let ((key1 (key-prompt "Enter a key sequence (or ? for summary): ")))
	       (cond
	         ((not (and (= (car key1) 0) (= (car (cdr key1)) 77)))
	           (let ((symbol (get-key-binding key1))
		   (description (get-key-name key1)))
		  (describe-internal description symbol
				 (catenate description "           " symbol))))
                   (t
		(init-local-displays)
		   (local-display-generator-nnl "(ESC x = press escape key then press x;   BS = BACKSPACE = CTL h;")
		   (local-display-generator-nnl " CTL x = CTRL = hold CONTROL key down while pressing x)")
                       (local-display-generator-nnl "@:  Erase to Start of Line CTLn: Next Line             ESCd: Erase Word")
                       (local-display-generator-nnl "BS:   Backward Erase Char  CTLp: Previous Line         ESCf: Forward Word")
                       (local-display-generator-nnl "CTLa: Start of Line        CTLy: Retrieve Erased Text  ESCn: Next Screen")
                       (local-display-generator-nnl "CTLb: Backward Char        ESC<: Start of Mailing List ESCp: Previous Screen")
                       (local-display-generator-nnl "CTLd: Erase Char           ESC>: End of Mailing List   ESCq: Finished with")
                       (local-display-generator-nnl "CTLe: End of Line          ESC?: Editor Help                 Mailing List")
                       (local-display-generator-nnl "CTLf: Forward Char         ESCb: Backward Word         ESCr: Redisplay")
                       (local-display-generator-nnl "CTLg: Exit help            ESCBS: Backward Erase Word  ESCu: Find Bad Addresses")
		   (local-display-generator-nnl "CTLk: Erase to End of Line")
		(end-local-displays))))
	  (xmail:mode-line)))

(defun display-buffer-as-printout ()
       (save-excursion
         (init-local-displays)
         (go-to-beginning-of-buffer)
         (do-forever
	 (local-display-generator (curline-as-string))
	 (if (lastlinep) (stop-doing))
	 (next-line))))

(xmail:start)




		    xmail_err_.alm                  11/05/86  1550.5r w 11/04/86  1038.5       26901



" ******************************************************
" *                                                    *
" * Copyright (c) 1986 by Massachusetts Institute of   *
" * Technology and Honeywell Information Systems, Inc. *
" *                                                    *
" * Copyright (c) 1972 by Massachusetts Institute of   *
" * Technology and Honeywell Information Systems, Inc. *
" *                                                    *
" ******************************************************

" HISTORY COMMENTS:
"  1) change(86-02-27,Blair), approve(86-02-27,MCR7358),
"     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
"     Added mailing_list and date_not_found.
"                                                      END HISTORY COMMENTS


include   et_macros

          et        xmail_err_

	ec        no_help_available,nohelp,(Sorry, there is no help available.)

	ec        unable_to_get_help,canthelp,(Sorry, unable to get help.)

	ec        invalid_range,invran,(The range specified is not valid.)

	ec        invalid_list,invlis,(The list specified is not valid.)

	ec        some_msgs_exist,somexst,(Only some of the messages specified exist.)

	ec        no_msgs_exist,noexst,(None of the messages specified exist.)

	ec        mailbox_empty,mbxemp,(There are no messages in this mailbox.)

          ec        all_msgs_deleted,alldel,(All of the messages have been discarded.)

	ec        int_prog_err,interr,(An internal programming error has occured.  Please see your site administrator for help.)

	ec	no_curr_msgs,nocurr,(There are no current messages specified.)

	ec	no_savebox,nsvbx,(The selected mail file does not exist.)

	ec	invalid_response,invresp,(The response is not an acceptable one.)

	ec	no_hardcopy,nhardcpy,(Sorry, but no information is available to explain how to get hardcopy to you.)

	ec	str_not_found,nostr,(No messages were found containing the specified string.)

	ec	date_not_found,nodate,(No messages were found within the specified dates.)

	ec	mailing_list,mlist,(The specified address is a mailing list.)

	ec	bad_mailing_list,badmlist,(The specified mailing list contains one or more invalid addresses.)

	ec	unrecognizable_addr,norecad,(The text specified is not a recognizable address.)

	ec	gen_help_req,genhelp,(The general help files have been requested.)

	ec	help_requested,help,(User requests usage information.)

	ec	exit_now,quit,(Immediate termination requested.)

	ec	no_deleted_msgs,nodel,(No messages have been discarded.)

	ec	bad_response,badresp,(Cannot use the given response.)

	ec	some_del_msgs_exist,somdexst,(Only some of the specified messages have been discarded.)

	ec	list_requested,lsrqst,(The user has requested a list.)

	ec	num_too_long,numlong,(Sorry, the specified number is too long.)

	ec	insuff_room_for_window,nowroom,(Sorry, there is insufficient room to create the specified window.)

	ec	insuff_room_for_xmail,noxroom,(The user_io window is too small for xmail.)

	end




		    xmail_error_.pl1                10/24/88  1700.5r w 10/24/88  1359.6      119745



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


/*
			xmail_error_

	The entries to this procedure all cause an error message to be
	displayed and/or logged.  They are similar in intent to com_err_
	or sub_err_, but are specialized for the xmail environment.

	All entries have the same calling sequence.  It must be declared
	options (variable), but has the following understood structure:

	entry (status, caller, disposition, ctl_string, args, ...)

	where STATUS is fixed bin (35) or some other computational type,
	CALLER is a fixed or varying character string,
	DISPOSITION is char (1),
	CTL_STRING is a fixed or varying character string,
	and ARGS are arguments referenced by the CTL_STRING.

	These are all analogous to com_err_ arguments except for disposition.
	It defines what action is taken after printing the error message,
	and may have the following values:

	"c" (continue) - return to caller.
          "i" (interupt) - signal quit.
	"l" (log)	     - log the error.  Then return to caller.
	"q" (quit)     - log the error.  Then signal quit.
	"s" (stop)     - log the error.  Then stop xmail totally.

	There are several entrypoints to this program.  They specify
	different ways of formatting the error message.  They are:

	code_last  - print the ctl_string message first, followed by the
		   error code in parentheses.

	code_first - print the error code first, followed by the ctl_string
		   message.

	no_code	 - print the ctl_string message, but not the error code.

	no_print	 - print nothing, but take other actions specified by the
		   disposition.

	When logging takes place, all relevant information is retained,
	whether it is printed or not.  In particular, the caller name is
	logged even though it is never printed, so it is important that
	it be passed correctly.

			xmail_error_modes

	This is a command entry.  It is provided for debugging purposes
	to control the operation of the subroutine entries.  It is
	described below.
*/

/* Written 6/16/81 by Paul Kyzivat	

   81-06-19  Paul Kyzivat: Modified to add xmail_error_modes entry 

   83-07-05  DJ Schimke: Removed unreferenced dcl of sys_info$max_seg_size
   and declared builtins addr, bin, and length.

   83-09-14 DJ Schimke: Modified the name of the error log segment from 
   Person_id.error to xmail.error since with this version (2.0) xmail shares 
   the mlsys directory (Person_id.mlsys). Renamed ERROR_LOG_SUFFIX to 
   ERROR_LOG_SEGMENT and changed the text of the printed message.

   84-06-21 JAFalksen: Utilize date_time_$format("date_time"
*/

/* format: style1 */
xmail_error_: proc options (variable);

	dcl     DEBUG		 bit (1) aligned static init ("0"b);
	dcl     ERROR_LOG_SEGMENT	 char (11) init ("xmail.error") int static options (constant);

code_last: entry options (variable);

	call XMAIL_ERROR ("^[^s^[^a (^s^a)^;^2s^a^]^/^;^s^[^a^/^;^s^]^2s^]");
	return;

code_first: entry options (variable);

	call XMAIL_ERROR ("^[^a ^]^[^a^2s^/^;^s^[^/^]^s^]");
	return;

no_code: entry options (variable);

	call XMAIL_ERROR ("^2s^[^a^/^;^s^]^2s");
	return;

no_print: entry options (variable);

	call XMAIL_ERROR ("^6s");
	return;
%page;
XMAIL_ERROR:
	/*** must be quick ***/
     proc (format);

	dcl     format		 char (*);

	dcl     arg_list		 ptr,
	        status		 fixed bin (35),
	        status_text		 char (100) aligned,
	        disposition		 char (1) aligned;

	dcl     caller_p		 ptr,
	        caller_l		 fixed bin (21),
	        caller		 char (caller_l) based (caller_p);

	dcl     disposition_arg_p	 ptr,
	        disposition_arg_l	 fixed bin (21),
	        disposition_arg	 char (disposition_arg_l) based (disposition_arg_p);

	dcl     caller_msg_p	 ptr,
	        caller_msg_l	 fixed bin (21),
	        caller_msg		 char (caller_msg_l) based (caller_msg_p);

	dcl     program_interrupt	 condition;

	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     cu_$arg_list_ptr	 entry (ptr),
	        ioa_		 entry () options (variable),
	        ioa_$nnl		 entry () options (variable);

	dcl     char		 builtin;

	call cu_$arg_list_ptr (arg_list);
	call GET_STATUS (arg_list, 1, status, status_text);
	call GET_STRING_ARG (arg_list, 2, caller_p, caller_l);
	call GET_STRING_ARG (arg_list, 3, disposition_arg_p, disposition_arg_l);
	call GET_CALLER_MSG (arg_list, 4, caller_msg_p, caller_msg_l);

	disposition = char (disposition_arg, 1);

	if DEBUG
	then call ioa_ ("^a: ^a ^a", caller, status_text, caller_msg);
	else call ioa_$nnl (format,
		status ^= 0, status_text,
		caller_msg ^= "", caller_msg,
		status ^= 0, status_text);

	if disposition = "c" then return;
	if disposition = "i" then signal condition (program_interrupt);
	else call MAKE_LOG_ENTRY (disposition, status, status_text, caller, caller_msg);

	if disposition = "l" then return;
	else if disposition = "s" then do;
		call ioa_ ("Exiting executive mail due to internal error. Please try again.^/If error persists please seek expert advice. ^/This error logged in ""^a"" in your xmail directory.^/ (^a)", ERROR_LOG_SEGMENT, xmail_data.mail_dir);
		call timer_manager_$sleep (20, "11"b);
		go to xmail_data.quit_label;
	     end;
	else /* disposition="q" or illegal value */
	     signal condition (program_interrupt);

     end XMAIL_ERROR;
%page;
GET_STATUS: proc (arg_list, argno, code, msg);

	dcl     arg_list		 ptr,
	        argno		 fixed bin,
	        code		 fixed bin (35),
	        msg		 char (100) aligned;

	dcl     type		 fixed bin,
	        ndims		 fixed bin,
	        prec		 fixed bin,
	        scale		 fixed bin,
	        packed		 bit (1) aligned;

	dcl     (addr, bin)		 builtin;

	dcl     arg_p		 ptr,
	        arg		 fixed bin (35) based (arg_p);

	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	        decode_descriptor_	 entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin),
	        convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);

	call cu_$arg_ptr_rel (argno, arg_p, (0), code, arg_list);
	if code = 0 then do;
		call decode_descriptor_ (arg_list, argno, type, packed, ndims, prec, scale);
		if (type = real_fix_bin_1_dtype) & (packed = "0"b)
		then code = arg;
		else do;
			intype = 2 * type + bin (packed, 1);

			if (type >= bit_dtype) & (type <= varying_char_dtype)
			then inclength = prec;
			else do;
				info.inscale = scale;
				info.inprec = prec;
			     end;
			outtype = 2 * real_fix_bin_1_dtype;
			outfo.outscale = 0;
			outfo.outprec = 35;
			call assign_ (addr (code), outtype, outscale_prec, arg_p, intype, inscale_prec);
		     end;
	     end;

	if code = 0 then msg = "";
	else call convert_status_code_ (code, (""), msg);
	return;
%page;
%include desc_dcls;
%page;
%include std_descriptor_types;

     end GET_STATUS;
%page;
GET_STRING_ARG: proc (arg_list, argno, string_p, string_l);

	dcl     arg_list		 ptr,
	        argno		 fixed bin,
	        string_p		 ptr,
	        string_l		 fixed bin (21);

	dcl     type		 fixed bin,
	        code		 fixed bin (35),
	        varying_string_length	 fixed bin (35) based;

	dcl     cu_$arg_ptr_rel	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	        decode_descriptor_	 entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);

	dcl     (addr, addrel)	 builtin;

	call cu_$arg_ptr_rel (argno, string_p, string_l, code, arg_list);
	if code ^= 0 then do;
		string_p = addr (string_p);
		string_l = 0;
	     end;
	else do;
		call decode_descriptor_ (arg_list, argno, type, (""b), (0), (0), (0));
		if type = varying_char_dtype
		then string_l = addrel (string_p, -1) -> varying_string_length;
	     end;
	return;
%page;
%include std_descriptor_types;

     end GET_STRING_ARG;
%page;
GET_CALLER_MSG:
	/*** must be quick ***/
     proc (arg_list, argno, msg_p, msg_l);

	dcl     arg_list		 ptr,
	        argno		 fixed bin,
	        msg_p		 ptr,
	        msg_l		 fixed bin (21);

	dcl     msg_text		 char (256),
	        result_length	 fixed bin,
	        ctl_p		 ptr,
	        ctl_l		 fixed bin (21);

	dcl     ioa_$general_rs	 entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);

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

	call GET_STRING_ARG (arg_list, argno, ctl_p, ctl_l);
	if ctl_l = 0 then do;
		msg_p = addr (msg_p);
		msg_l = 0;
	     end;
	else do;
		msg_p = addr (msg_text);
		call ioa_$general_rs (arg_list, argno, argno + 1, msg_text, result_length, "0"b, "0"b);
		msg_l = length (rtrim (substr (msg_text, 1, result_length)));
	     end;

     end GET_CALLER_MSG;
%page;
MAKE_LOG_ENTRY: proc (action, code, code_msg, caller, caller_msg);

	dcl     action		 char (1) aligned,
	        code		 fixed bin (35),
	        code_msg		 char (100) aligned,
	        caller		 char (*),
	        caller_msg		 char (*);

	dcl     (TAB		 init ("	"),
	        NL		 init ("
")	        )			 char (1) int static options (constant);
	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35));
	dcl     date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
	dcl     hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));

	dcl     bit_count		 fixed bin (24);
	dcl     status		 fixed bin (35);
	dcl     date_time_str	 char (64) var;
	dcl     error_log_len	 fixed bin;
	dcl     error_log_ptr	 ptr init (null);
	dcl     error_log		 char (error_log_len) based (error_log_ptr);
	dcl     (clock, divide, null, rtrim) builtin;
	dcl     error_table_$noentry	 fixed bin (35) ext static;

	call hcs_$initiate_count ((xmail_data.mail_dir), ERROR_LOG_SEGMENT, "", bit_count, 1, error_log_ptr, status);
	if status = error_table_$noentry
	then do;
		call hcs_$make_seg ((xmail_data.mail_dir), ERROR_LOG_SEGMENT, "", RW_ACCESS_BIN, error_log_ptr, status);
		if status ^= 0 then return;
		error_log_len = 0;
	     end;
	else if error_log_ptr = null
	then return;
	else error_log_len = divide (bit_count + 8, 9, 24, 0);

	date_time_str = date_time_$format ("date_time", clock (), "", "");

	call add_to_error_log (rtrim (date_time_str) || NL ||
	     TAB || "Error detected by = """ || rtrim (caller) || """" || NL ||
	     TAB || "Status code message = """ || rtrim (code_msg) || """" || NL ||
	     TAB || "Caller message = """ || rtrim (caller_msg) || """" || NL ||
	     TAB || "Action to be taken = """ || rtrim (action) || """" ||
	     NL || NL, status);
	if status ^= 0 then return;

	call adjust_bit_count_ ((xmail_data.mail_dir), (ERROR_LOG_SEGMENT), "1"b, (0), status);

add_to_error_log: proc (P_str, P_code);

	dcl     P_str		 char (*);
	dcl     P_code		 fixed bin (35);
	dcl     (length, substr)	 builtin;
	dcl     starting_col	 fixed bin init (error_log_len + 1);

	P_code = 0;

	error_log_len = error_log_len + length (P_str);
	substr (error_log, starting_col) = P_str;

     end add_to_error_log;
%page;
%include access_mode_values;

     end MAKE_LOG_ENTRY;
%page;
/*
			xmail_error_modes

This command sets/prints modes which control the operation of the various
xmail_error_ entries.

Usage:
	xmail_error_modes {mode_string}

Description:
	If mode_string is present it is processed and the corresponding
modes set.  If not present, the current mode settings are printed.

Currently, the only defined mode is debug/^debug.  When set, it causes
error messages to be printed always in com_err_ format.
*/

xmail_error_modes: entry options (variable);

MODES:	begin /* options (quick) */;

	     dcl	   NAME		      init ("xmail_error_modes") char (17) static options (constant);

	     dcl	   nargs		      fixed bin,
		   code		      fixed bin (35),

		   arg_p		      ptr,
		   arg_l		      fixed bin (21),
		   arg		      char (arg_l) based (arg_p);

	     dcl	   error_table_$too_many_args fixed bin (35) ext static,
		   error_table_$bad_mode  fixed bin (35) ext static;

	     dcl	   cu_$arg_count	      entry (fixed bin, fixed bin (35)),
		   cu_$arg_ptr	      entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
		   com_err_	      entry () options (variable),
		   ioa_		      entry () options (variable);

	     call cu_$arg_count (nargs, code);
	     if code = 0 & nargs > 1 then code = error_table_$too_many_args;
	     if code = 0 & nargs = 1 then call cu_$arg_ptr (1, arg_p, arg_l, code);
	     if code ^= 0 then do;
		     call com_err_ (code, NAME);
		     return;
		end;

	     if nargs = 0
	     then call ioa_ ("^[^;^^^]debug", DEBUG);
	     else do;
		     if arg = "debug" then DEBUG = "1"b;
		     else if arg = "^debug" then DEBUG = "0"b;
		     else call com_err_ (error_table_$bad_mode, NAME, "^a", arg);
		end;
	end MODES;

%page;
%include xmail_data;

     end xmail_error_;




		    xmail_file_msgs_.pl1            09/02/88  0759.6r w 09/02/88  0745.0      193563



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



/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     Added a new entrypoint to handle the case when both the original
     and the reply are to be filed.
  2) change(86-01-17,Blair), approve(86-02-26,MCR7358),
     audit(86-05-19,RBarstad), install(86-05-28,MR12.0-1062):
     Call xmail_error_ with disposition "c" instead of "i" when the user types
     "no" to creating a new file. TR 20028.
  3) change(87-01-19,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Check to see whether or not we're dealing with all the messages in a
     mailbox or only the ordinary ones as indicatd by xmail_data.msgs_as_mail.
                                                   END HISTORY COMMENTS */


xmail_file_msgs_: proc ();


/* BEGIN DESCRIPTION

history:       Author unknown.

   83-07-05  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-10-06  DJ Schimke: Changed call to xmail_get_str_ to call to new entry
   xmail_get_str_$yes_no. Reorganized the code into two separate entrypoints:
   1) current_msgs to provide the old function of filing all messages in 
      the current_msgs structure.
   2) single_msg to provide a new message filing function for xmail_reply, 
      xmail_send_msg etc. 

   83-11-01  DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-08-21  JG Backs: Modified the error code handling of mail_system_$save_
   message call within file_message internal procedure to report a better 
   message if there was incorrect access to a save mailbox. phx18059.

   84-10-24  JG Backs: Modified the error code handling of mail_system_$save_
   message call within file_message internal procedure to report a better
   message if the file becomes full during filing.  This also required that
   the entrypoint $single_msg always set the message_num to 1, so if the file
   is full on the 1st message, internal proc print_filed_msg is not called.

   84-10-29  JG Backs: Added three new internal procedures, save_message_count,
   backout_filed_msgs, and close_file, to better handle the "mailbox_full"
   situation.  If a file becomes full during the filing of more than one
   message, the user is informed and the messages already filed are backed out.

   84-11-26  JG Backs: Modified the save_message_count internal procedure to 
   test smc_code for error_table_$noentry rather than mlsys_et_$no_savebox
   after calling mail_system_$get_message_counts.  This is the code that is 
   returned when a file does not exist and is being created.


END DESCRIPTION
*/

/* PARAMETERS */

	dcl     P_curr_msgsp	 ptr parm;	/* ptr to current msgs structure */
	dcl     P_default_file	 char (32) var parm;/* default target file           */
	dcl     P_mailbox_ptr	 ptr parm;	/* ptr to source mailbox         */
	dcl     P_msg_ptr		 ptr parm;	/* ptr to msg to be filed        */
	dcl     P_orig_msg_ptr         ptr parm;          /* ptr to original msg to file   */
          dcl     P_reply_msg_ptr        ptr parm;          /* ptr to the reply msg          */
	dcl     P_allow_selection	 bit (1) aligned parm;
						/* do we use the default file or */
						/* can we select another?        */


/* ENTRIES */

	dcl     continue_to_signal_	 entry (fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     mail_system_$close_mailbox entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$get_message_counts entry (char (*), char (*), bit (1) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     mail_system_$mark_message_for_deletion entry (ptr, fixed bin (35));
	dcl     mail_system_$open_mailbox entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$save_message entry (ptr, char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_select_file_	 entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, char (168),
				 char (32) var, bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));

/* CONSTANTS */

	dcl     ACCEPT_OLD		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     ACCEPT_NEW		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     CURRENT		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     MY_NAME		 char (16) static options (constant) init ("xmail_file_msgs_");
	dcl     SECONDS		 bit (2) int static options (constant) init ("11"b);
	dcl     SINGLE		 bit (1) aligned int static options (constant) init ("0"b);
	dcl     SP		 char (1) aligned int static options (constant) init (" ");
	dcl     MORE_MSG		 char (12) aligned int static options (constant) init (" ... <MORE> ");

/* EXTERNAL STATIC */

	dcl     error_table_$badcall	 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$rqover	 fixed bin (35) ext static;
	dcl     iox_$user_output	 ptr ext static;
	dcl     mlsys_et_$mailbox_full fixed bin (35) ext static;
	dcl     mlsys_et_$no_a_permission fixed bin (35) ext static;
	dcl     mlsys_et_$no_r_permission fixed bin (35) ext static;
	dcl     mlsys_et_$no_savebox	 fixed bin (35) ext static;
	dcl     mlsys_et_$savebox_created fixed bin (35) ext static;
	dcl     xmail_err_$no_curr_msgs fixed bin (35) ext static;
	dcl     xmail_err_$no_savebox	 fixed bin (35) ext static;

/* AUTOMATIC */

	dcl     add_more_msg	 bit (1) aligned;
	dcl     allow_selection	 bit (1) aligned;
	dcl     code		 fixed bin (35);
	dcl     create_if_not_found	 bit (1) aligned;
	dcl     default_file	 char (32) var;
	dcl     dir		 char (168);
	dcl     file_mode		 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     prefix		 char (32) var;
	dcl     message_count	 fixed bin;
	dcl     message_num		 fixed bin;
	dcl     message_no_string	 char (200) var;
	dcl     message_ptr		 ptr init (null);
          dcl     msg_filed_sw           bit (1) aligned;        
	dcl     needs_filing	 bit (1);
	dcl     original_message_count fixed bin;
	dcl     prompt_string	 char (256) var;
	dcl     unused_return_length	 fixed bin;
	dcl     yes_sw		 bit (1) aligned;
	dcl     unused_bit		 bit (1) aligned;

	dcl     1 auto_open_options	 like open_options;
	dcl     1 auto_close_options	 like close_options;

/* BUILTIN */

	dcl     (addr, char, length, ltrim, maxlength, null)
				 builtin;

/* CONDITIONS */

	dcl     (quit)		 condition;

/* INCLUDE FILES */

%include mlsys_mailbox;
%page;
%include mlsys_open_options;
%page;
%include mlsys_close_options;
%page;
%include window_dcls;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_data;

/* BEGIN */

	call xmail_error_$code_first (error_table_$badcall, MY_NAME, "q",
	     "This is an internal programming error.");

/* ENTRY POINTS */

current_msgs: entry (P_mailbox_ptr, P_curr_msgsp, P_default_file, P_allow_selection);

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

   This entrypoint attempts to file all messages in the current message
   structure.  If P_allow_selection is "on", the user is prompted for a
   mailfile to file into with P_default_file (if given) as the default
   choice. It is invalid to call this entry with P_allow_selection "off"
   and P_default_file = "".
   The main work is done by the call to the file_message internal proc.
   On mailbox_full error, the user is informed, the messages already filed
   are backed out, and processing aborted by calling xmail_error_.  This
   signals quit and returns to the menu.
   On any other error, file_message prints the messages that have
   successfully been filed and then aborts by calling xmail_error_.
							
  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, MY_NAME, "q", "Invalid mailbox structure.  This is an internal programming error.");

	if P_curr_msgsp = null
	then call xmail_error_$code_first (xmail_err_$no_curr_msgs, MY_NAME, "i");
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, MY_NAME, "q", "Invalid message structure.  This is an internal programming error.");

	end;

	curr_msgsp = P_curr_msgsp;
	mailbox_ptr = P_mailbox_ptr;
	default_file = P_default_file;
	allow_selection = P_allow_selection;
	file_mode = CURRENT;
	msg_filed_sw = "0"b;

	if allow_selection then do;
	     call xmail_select_file_ ("mail file", "sv.mbx", (default_file), ACCEPT_OLD, ACCEPT_NEW, dir, prefix, create_if_not_found, unused_bit, code);
	     if code ^= 0 then go to CURRENT_EXIT;	/* Diagnostic msg already issued by xmail_select_file_. */
	end;
	else do;					/* for archive etc */
	     dir = xmail_data.mail_dir;
	     prefix = default_file;
	     create_if_not_found = "1"b;
	end;

	message_no_string = "";
	add_more_msg = "0"b;
	message_count = curr_msgs.count;

/* If there is more than 1 message, save total count of messages before
   filing in case mail file becomes full and messages have to be deleted. */

	if message_count > 1
	then call save_message_count;

/* Loop for every message to be filed */

	do i = 1 to curr_msgs.count;
	     message_num = curr_msgs.numbers (i);
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		call mail_system_$read_message (mailbox_ptr, message_num, code);
		if code ^= 0
		then call xmail_error_$no_code (code, MY_NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
	     end;
	     message_ptr = mailbox.messages (message_num).message_ptr;
	     call file_message;			/* this call does the work */
	     if length (message_no_string) + length (ltrim (char (message_num))) + length (SP) > maxlength (message_no_string)
	     then add_more_msg = "1"b;
	     else message_no_string = message_no_string || ltrim (char (message_num)) || SP;
	end;

          if msg_filed_sw
	     then call print_filed_msg;
	P_default_file = prefix;
	
CURRENT_EXIT:
	return;

single_msg: entry (P_msg_ptr, P_default_file, P_allow_selection);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry point performs the same function as the above entry except that	        */
/* it takes a single message ptr as input and files only that message. This	        */
/* allows send_message, reply_message etc. to call a common routine for filing.	        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

  

	file_mode = SINGLE;
	msg_filed_sw = "0"b;
	
	message_count = 1;				/* always 1 in case of problems in filing */
	message_ptr = P_msg_ptr;
	default_file = P_default_file;
	allow_selection = P_allow_selection;

	if allow_selection then do;
	     call xmail_select_file_ ("mail file", "sv.mbx", (default_file), ACCEPT_OLD, ACCEPT_NEW, dir, prefix, create_if_not_found, unused_bit, code);
	     if code ^= 0 then go to SINGLE_EXIT;	/* Diagnostic msg already issued by xmail_select_file_. */
	end;
	else do;					/* for archive etc */
	     dir = xmail_data.mail_dir;
	     prefix = default_file;
	     create_if_not_found = "1"b;
	end;

	call file_message;

	if msg_filed_sw 
	     then call ioa_ ("Message filed in ""^a"".", prefix);
	P_default_file = prefix;

SINGLE_EXIT:

	return;

original_and_reply: entry (P_orig_msg_ptr, P_reply_msg_ptr, P_default_file, P_allow_selection);
		

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point performs the same function as the above entry except that it takes	*/
	/* two message pointers as input; the pointer to the original message and the pointer to	*/
	/* the message created from the reply. This entry is called only by reply_message when	*/
	/* the original is to be filed before the reply. Because of the need to preserve backing	*/
	/* out previously filed messages when a file is full ( which makes two calls to		*/
	/* single_msg useless), and the fact that both messages aren't in the same mailbox) this	*/
	/* entry point seems to be the only alternative.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	file_mode = SINGLE;

	msg_filed_sw = "0"b;
	message_count = 1;
	message_ptr = P_orig_msg_ptr;
	default_file = P_default_file;
	allow_selection = P_allow_selection;
	
	if allow_selection then do;
	     call xmail_select_file_ ("mail file", "sv.mbx", (default_file), ACCEPT_OLD, ACCEPT_NEW, dir, prefix,create_if_not_found, unused_bit, code);
	     if code ^= 0 then go to ORIG_AND_REPLY_EXIT;
	     end;
	else do;
	     dir = xmail_data.mail_dir;
	     prefix = default_file;
	     create_if_not_found = "1"b;
	     end;
	
	call file_message;
	if msg_filed_sw
	     then call ioa_ ("Original filed in ""^a"".", prefix);
	else
	     call ioa_ ("Original was not filed.");
		
	message_count = 2;
	message_ptr = P_reply_msg_ptr;
	msg_filed_sw = "0"b;
		
	call file_message;
	if msg_filed_sw
	     then do;
	     call ioa_ ("Message filed in ""^a"".", prefix);
	     P_default_file = prefix;
	     end;
	else
	     P_default_file = "";
		
	
ORIG_AND_REPLY_EXIT:
	
	return;

/* INTERNAL PROCEDURES */

file_message: proc;


	needs_filing = "1"b;
	do while (needs_filing);
	     call mail_system_$save_message (message_ptr, dir, (prefix), create_if_not_found, code);
	     if code = 0
	     then do;
		needs_filing = "0"b;
		msg_filed_sw = "1"b;
		end;
	     
	     else if code = mlsys_et_$no_savebox
	     then do;
		call ioa_$rsnnl ("The specified mail file ""^a"" does not exist.^/Do you wish to create it?  ", prompt_string, unused_return_length, prefix);
		call xmail_get_str_$yes_no (prompt_string, yes_sw);
		if yes_sw then create_if_not_found = "1"b;
		else if xmail_data.cleanup_signalled
		then call xmail_error_$no_code (xmail_err_$no_savebox, MY_NAME, "i",
		     "No messages have been filed.");
		else do;
		     call xmail_error_$no_code (xmail_err_$no_savebox, MY_NAME, "c", "No messages have been filed.");
		     needs_filing = "0"b;
		     msg_filed_sw = "0"b;
		     P_default_file = "";
		     goto CURRENT_EXIT;
		     end;
	     end;

	     else if code = mlsys_et_$savebox_created
	     then do;
		call ioa_ ("The mail file ""^a"" has been created.", prefix);
		msg_filed_sw = "1"b;
		needs_filing = "0"b;
	     end;

/* If directory or file has become full, inform user and backout previosly
   filed messages if no. of messages was greater than one.   */

	     else if code = error_table_$rqover
	     then do;
		if message_count = 1
		then call xmail_error_$no_code (code, MY_NAME, "q", "Unable to file message.  Your directory is full.");
		else do;
		     call ioa_ ("Unable to continue filing.  Your directory is full.");
		     call backout_filed_msg;
		     call xmail_error_$no_code (code, MY_NAME, "q", "Filing terminated because the directory was full.^/  No messages were filed.");
		end;
	     end;

	     else if code = mlsys_et_$mailbox_full
	     then do;
		if message_count = 1
		then call xmail_error_$no_code (code, MY_NAME, "q", "Unable to file message. The ""^a"" file is full.", prefix);
		else do;
		     call ioa_ ("Unable to continue filing.  The ""^a"" file is full.", prefix);
		     call backout_filed_msg;
		     call xmail_error_$no_code (code, MY_NAME, "q", "Filing terminated because the ""^a"" file was full.^/  No messages were filed.", prefix);
		end;
	     end;

	     else if code = mlsys_et_$no_a_permission
	     then call xmail_error_$no_code (code, MY_NAME, "q", "  Unable to file message.  You do not have access to the ""^a"" mail file.", prefix);

	     else do;
		if file_mode = CURRENT then do;
		     call print_filed_msg;
		     call xmail_error_$no_code (code, MY_NAME, "q", "Unable to file msg^[ ^d.^;.^] This is an internal programming error.", (message_num > 0), message_num);
		end;
		else call xmail_error_$no_code (code, MY_NAME, "q", "Unable to file msg. This is an internal programming error.");
		needs_filing = "0"b;
	     end;
	end;					/* while need filing */

     end file_message;

print_filed_msg: proc;

/* Lists the messages that have been successfully filed. */

	call ioa_ ("Message^[s^;^] ^a ^[^a^;^s^] filed in ""^a"".", (curr_msgs.count > 1), message_no_string, add_more_msg, MORE_MSG, prefix);
     end print_filed_msg;

save_message_count: proc ();

/* This new internal procedure will save the original message count where 
   messages are to be filed, to be used in case file becomes full  */

	dcl     smc_code		 fixed binary (35);

/* BEGIN */

	smc_code = 0;
	original_message_count = 0;

	call mail_system_$get_message_counts (dir, (prefix || ".sv"), "1"b, (0), original_message_count, (0), smc_code);
	if smc_code = mlsys_et_$no_r_permission
	then call xmail_error_$no_code (smc_code, MY_NAME, "q", "You do not have access to read the ""^a"" mail file.", prefix);
	else if smc_code = error_table_$noentry
	then original_message_count = 0;
	else if smc_code ^= 0
	then call xmail_error_$no_code (smc_code, MY_NAME, "q", "Unable to determine message count on ""^a"" mail file.  This file cannot be used.", prefix);
	return;

     end save_message_count;

backout_filed_msg: proc ();

/* This new internal procedure will delete all the current messages, if more
   than one, that were filed just before the mailbox full error. It uses the
   original message count determined in save_message_count proc.   */

	dcl     bfm_code		 fixed binary (35);
	dcl     bfm_mailbox_ptr	 ptr;
	dcl     bfm_message_ptr	 ptr;

/* BEGIN */

	call ioa_ ("^/  Backing out partially stored messages.  This may take awhile...");
	bfm_code = 0;
	bfm_mailbox_ptr = null ();
	bfm_message_ptr = null ();

	on condition (quit)
	     begin;
		if bfm_mailbox_ptr ^= null ()
		then do;
		     call ioa_ ("Closing file.  Partially stored messages may not be all backed out.");
		     call close_file;
		end;
		call continue_to_signal_ ((0));
	     end;

/* Set up to open mailbox to discard the already filed messages. */

	if xmail_data.msgs_as_mail then
	auto_open_options.message_selection_mode = ALL_MESSAGES;
	else auto_open_options.message_selection_mode = ORDINARY_MESSAGES;
	auto_open_options.version = OPEN_OPTIONS_VERSION_2;
	auto_open_options.sender_selection_mode = ACCESSIBLE_MESSAGES;
	auto_open_options.message_reading_level = READ_KEYS;

	call mail_system_$open_mailbox (dir, (prefix || ".sv"), addr (auto_open_options), MAILBOX_VERSION_2, bfm_mailbox_ptr, bfm_code);
	if bfm_code ^= 0
	then call xmail_error_$no_code (bfm_code, MY_NAME, "q", "Unable to open ""^a"" mail file to backout partially filed messages.", prefix);

	do i = original_message_count + 1 to bfm_mailbox_ptr -> mailbox.n_messages;
	     if bfm_mailbox_ptr -> mailbox.messages (i).message_ptr = null ()
	     then do;
		call mail_system_$read_message (bfm_mailbox_ptr, i, bfm_code);
		if bfm_code ^= 0
		then call xmail_error_$no_code (bfm_code, MY_NAME, "l", "Unable to read message ^d while backing out partially filed messages.", i);
	     end;
	     bfm_message_ptr = bfm_mailbox_ptr -> mailbox.messages (i).message_ptr;
	     call mail_system_$mark_message_for_deletion (bfm_message_ptr, bfm_code);
	     if bfm_code ^= 0
	     then call xmail_error_$no_code (bfm_code, MY_NAME, "l", "Unable to backout filed message ^d from ""^a"" mail file.", i, prefix);
	end;

/* After all messages are discarded, close mailbox, which will actually delete
   the messages, then clear window */

	call close_file;
	call timer_manager_$sleep (4, SECONDS);		/* give user time to read */
	call window_$clear_window (iox_$user_output, (0));/* ignore code */
	return;

close_file: proc;

/* Internal procedure to close mail file that was opened to delete messages.
   Called from backout_filed_msg and if quit during backout_filed_msg. */

	auto_close_options.version = CLOSE_OPTIONS_VERSION_2;
	auto_close_options.flags.perform_deletions = "1"b;
	auto_close_options.flags.report_deletion_errors = "0"b;
	auto_close_options.flags.mbz = "0"b;

	call mail_system_$close_mailbox (bfm_mailbox_ptr, addr (auto_close_options), bfm_code);
	if bfm_code ^= 0
	then call xmail_error_$no_code (bfm_code, MY_NAME, "l", "Unable to close ""^a"" mail file after backing out partially filed messages.", prefix);
	return;

     end close_file;

     end backout_filed_msg;

     end xmail_file_msgs_;





		    xmail_forward_msg_.pl1          09/02/88  0759.6rew 09/02/88  0736.0      271179



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


/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-03-19,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-01 JG Backs: Deleted the constant ASK because it was added to the
     include file xmail_responses.incl.pl1 and resulted in a compiler warning.
  2) change(86-01-07,Blair), approve(86-03-19,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Rearranged the code to perform the savefile after the message has
     already been forwarded and made the create savefile consistent with
     reply and send. Took out the allocation of the bcc list in the recip-
     ient_info structure.
  3) change(86-01-28,Blair), approve(86-03-19,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Added an on unit for the reissue_query condition signalled by the
     xmail_window_manager_$quit_handler routine when the user types a break in
     response to a question.  This allows the question to be reissued so that
     the user isn't left hanging.  It also allows the choices menu to be
     redrawn if the user types quit instead of making a selection and then
     decides to continue.  TRs 18711 18974.
  4) change(86-07-30,Blair), approve(86-07-30,MCR7498),
     audit(86-08-19,Gilcrease), install(86-08-21,MR12.0-1138):
     Restore the save message query sequence to occur before the message is
     forwarded so that the REDISTRIBUTED-TO part of the header is included in
     the saved msg. If the user types "no" to creating a new_file the msg will
     be forwarded anyway. If he types a break, he will re-enter the sequence
     asking him if he wants to save the message.  error_list #127.
  5) change(88-06-29,Blair), approve(88-07-27,MCR7931),
     audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098):
     Use the correct mail_system_ entrypoints to generate the to_list ptr,
     create an address and add it to the list, rather than generating the list
     ourselves by constructing an address of the type "{keyword ...}". This
     will allow us to correctly deal with mailbox names that include embedded
     blanks.
                                                   END HISTORY COMMENTS */

xmail_forward_msg_: procedure (P_mailbox_ptr, P_curr_msgs_ptr);

/* BEGIN DESCRIPTION

function:

    This proc is invoked as a consequence of the user selecting the 
"Forward"  option in the Process Mail or Process Filed Mail menus.
It uses the mail_system_$redistribute_message procedure to 
actually do the forwarding. xmail_forward_msg_ calls emacs_ to allow the user
to specify the recipients to whom the message is being forwarded.
The user may enter a comment if he/she wishes.
Note that xmail_forward_msg_ assumes that the addresses are "clean", i.e.,
they neither contain syntax errors nor is there an address for which there
is no corresponding mailbox. The "xmail_emacs_ext_main_" emacs extention
insures that the addresses are "clean". 
The procedure loops based on the number of messages being forwarded. 


history:          Written by R. Ignagni 7/11/81 

   83-07-05  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-10-06  DJ Schimke: Changed all calls to xmail_get_str to calls to
   xmail_get_str_$yes_no;

   83-10-17 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a 
   call to xmail_window_manager_$quit_handler so the quit condition handler
   can special-case the reconnect condition which should NOT interrupt 
   processing after the quit. phx 13227 This entrypoint also prompts when not
   at a reconnect condition so that unintentionally hitting the BREAK won't
   throw away any pending work. phx 13018

   83-11-23 DJ Schimke: Added support for the new personalization option
   "Outgoing Savefile" which allows selection of where to file save messages.
   This also solves the discrepancy between setting "Save Outgoing messages"
   to "yes" and never having set "Save Outgoing messages".

   83-12-07 DJ Schimke: Cleaned up the reporting of delivery results by calling
   mlsys_utils_$print_delivery_results_ and mlsys_utils_$print_address_field 
   for displaying the failure/success of sending. This module still needs 
   recovery code to allow the sender to correct the bad addresses and continue.

   83-12-08 DJ Schimke: Added simple flag to prevent the call to 
   mlsys_util_$free_delivery_results until the call to send the msg has been 
   made. Otherwise, this cleanup will get errors referencing invalid pointers.

   83-02-20 DJ Schimke: Modified the cleanup code so recipients_info is only
   freed by the CLEANUP procedure rather than by the MESSAGE_CLEANUP procedure.
   This fixes a problem referencing recipients_info when forwarding more than 
   one message (curr_msgs.count > 1). 

   84-09-24 JG Backs: Added code before and after the call to emacs_ to test
   if menus should be removed before editing (personalization option Remove
   Menus While Editing).  If option is in effect, calls to new entrypoints,
   $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also
   added test in quit handler to make sure restore menus is done if quit in
   editor.

   84-11-14 JG Backs: Moved the code, which redisplays the menu if removed
   while editing, to execute after the call to CLEAN_UP rather than within
   the CLEAN_UP procedure.  This prevents screen output during a true cleanup
   condition.


END DESCRIPTION
*/

/* PARAMETERS */

	dcl     P_mailbox_ptr	 ptr parameter;
	dcl     P_curr_msgs_ptr	 ptr parameter;

/* CONDITIONS */

	dcl     (quit, cleanup, reissue_query)	 condition;


/* CONSTANTS */

          dcl     ACCEPT_NEW             bit (1) aligned int static options (constant) init ("1"b);
          dcl     ACCEPT_OLD             bit (1) aligned int static options (constant) init ("1"b);
	dcl     ACKNOWLEDGE		 char (14) static options (constant) init ("acknowledge_yn");
	dcl     BITS_PER_CHAR	 fixed bin static options (constant) init (9);
	dcl     CONTINUE		 char (1) static options (constant) init ("c");
	dcl     DELETE_SEG_FORCE_CHASE bit (6) static options (constant) init ("100101"b);
	dcl     EMACS_EXT		 char (21) options (constant) init ("xmail_emacs_ext_main_") int static;
	dcl     ENTRY_NAME		 entry variable init (xmail_forward_msg_);
	dcl     ERROR_MESSAGE	 char (63) static options (constant) init ("Message no. ^d not forwarded, due to an internal program error.");
	dcl     ERRORS_ONLY		 bit (1) aligned static options (constant) init ("1"b);
	dcl     GO_ON		 char (57) static options (constant) init ("Do you wish to forward the rest of the current messages? ");
	dcl     LOG		 char (1) static options (constant) init ("l");
	dcl     MAILFILE_SUFFIX	 char (6) static options (constant) init ("sv.mbx");
	dcl     NAME		 char (18) static options (constant) init ("xmail_forward_msg_");
	dcl     NL		 char (1) aligned static options (constant) init ("
");
	dcl     PROBLEM		 char (61) static options (constant) init ("Forwarding not completed. An internal program error occurred.");
	dcl     QUIT		 char (1) static options (constant) init ("q");
	dcl     SAVE_MAILBOX	 char (15) static options (constant) init ("save_mailfile");
	dcl     SAVE_MESSAGE	 char (15) static options (constant) init ("save_message_yn");
	dcl     STOP		 char (1) static options (constant) init ("q");
	dcl     USE_SCREEN_WIDTH	 fixed bin aligned static options (constant) init (-1);
	dcl     WHITE_SPACE		 char (4) aligned static options (constant) init ("
 	");					/* HT VT NL <space> */
	dcl     WHITE_SPACE_COMMA	 char (6) aligned static options (constant) init ("
	  ,");					/* HT VT NL <space> comma */

/* EXTERNAL STATIC */

	dcl     error_table_$namedup	 static ext fixed bin (35);
	dcl     error_table_$segknown	 static ext fixed bin (35);
	dcl     error_table_$bad_segment fixed bin (35) ext static;
	dcl     iox_$user_output	 ptr external static;
	dcl     mlsys_et_$no_a_permission static ext fixed bin (35);

/* INTERNAL STATIC */

	dcl     ext_pname		 char (168) int static;
	dcl     ext_ptr		 ptr init (null) int static;
	dcl     ext_dir		 char (168) int static;
	dcl     ext_file		 char (32) int static;

/* AUTOMATIC */

	dcl     acknowledge		 char (3) var;
          dcl     ask_again              bit (1) aligned;
	dcl     bcc_list_ptr	 ptr;
	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     code1		 fixed bin (35);
          dcl     create                 bit (1) aligned;
	dcl     default_save_file	 char (32) var;
	dcl     delivery_results_need_cleanup bit (1) aligned;
	dcl     dir		 char (168);
	dcl     emacs_seg_path_name	 char (168);
	dcl     error_list_ptr	 ptr;
          dcl     exists                 bit (1) aligned;
	dcl     for_type		 char (32);
	dcl     forward_area_ptr	 ptr;
	dcl     forward_msg_ptr	 ptr;
	dcl     forward_seg_name	 char (32);
	dcl     forward_seg_ptr	 ptr;
	dcl     idx		 fixed bin;
	dcl     idx1		 fixed bin;
	dcl     message_num		 fixed bin;
	dcl     message_num1	 fixed bin;
	dcl     message_saved	 bit (1) aligned;
	dcl     no_chars		 fixed bin (21);
	dcl     opt                    fixed bin;
          dcl     prefix                 char (32) var;
          dcl     prompt_string          char (256) var;
	dcl     resp		 char (1) var;
	dcl     restore_menu_needed	 bit (1) aligned;	/* if remove menu */
	dcl     save_message	 char (3) var;
	dcl     sci_ptr		 ptr;
	dcl     to_list_ptr		 ptr;
	dcl     type		 fixed bin (2);
          dcl     unused_return_length   fixed bin;
	dcl     yes_sw		 bit (1) aligned;

	dcl     1 auto_deliver_options like deliver_options;
	dcl     1 auto_parse_text_options like parse_text_options;

/* ENTRIES */

	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35));
	dcl     emacs_		 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     get_pdir_		 entry () returns (char (168));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry options (variable);
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$nnl		 entry options (variable);
          dcl     ioa_$rsnnl             entry() options(variable);
          dcl     mail_system_$create_address_list entry (char (8), ptr, fixed bin (35));
          dcl     mail_system_$create_savebox_address entry (char (*) varying, char(*), char (*), char (*) varying, char (*) varying, pointer, fixed bin (35));
	dcl     mail_system_$free_address_list entry (ptr, fixed bin (35));
	dcl     mail_system_$free_message entry (ptr, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$redistribute_message entry (ptr, char (*), ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$free_delivery_results entry (ptr, fixed bin (35));
	dcl     mlsys_utils_$print_address_list_field entry (char (*) var, ptr, fixed bin, ptr, fixed bin (35));
	dcl     mlsys_utils_$print_delivery_results entry (ptr, bit (1) aligned, ptr, fixed bin (35));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     ssu_$destroy_invocation entry (ptr);
          dcl     suffixed_name_$make    entry (char(*), char(*), char(32), fixed bin(35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     xmail_error_$no_code	 entry options (variable);
	dcl     xmail_error_$no_print	 entry options (variable);
	dcl     xmail_error_$code_first entry options (variable);
	dcl     xmail_forward_msg_$ssu_exit entry ();
	dcl     xmail_get_str_	 entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_redisplay_$menu	 entry options (variable);
          dcl     xmail_select_file_     entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
                                         char (168), char (32) var, bit (1) aligned, bit (1) aligned, fixed bin (35));     
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     xmail_sw_$update_usage entry (char (*));
	dcl     xmail_value_$get	 entry (char (*), char (*) var, fixed bin (35));
	dcl     xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35));
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_window_manager_$restore_menu entry ();
	dcl     xmail_window_manager_$suppress_menu entry ();
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
          dcl     mlsys_utils_$create_savebox entry options(variable);
	dcl     mlsys_utils_$parse_address_list_text entry (char (*), ptr, char (8), ptr, ptr, fixed bin (35));

/* BASED */

	dcl     based_string	 char (no_chars) based (forward_seg_ptr);

/* AREA */

	dcl     forward_area	 area aligned based (forward_area_ptr);

/* BUILTINS */

	dcl     (addr, after, before, char, codeptr, divide, length, ltrim, null, rtrim) builtin;

/* INCLUDE FILES */

%include access_mode_values;
%page;
%include mlsys_message;
%page;
%include mlsys_address_list;
%page;
%include mlsys_deliver_info;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_parse_txt_options;
%page;
%include terminate_file;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_data;
%page;
%include xmail_responses;
%page;
%include window_dcls;

/* BEGIN */

	error_list_ptr = null ();
	forward_msg_ptr = null ();
	forward_seg_ptr = null ();
	recipients_info_ptr = null ();
	sci_ptr = null ();
	to_list_ptr = null ();
	bcc_list_ptr = null;
	delivery_results_need_cleanup = "0"b;
	restore_menu_needed = "0"b;

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgs_ptr;
	if mailbox_ptr = null () | curr_msgsp = null ()
	then do;
	     call ioa_ ("All messages have been discarded.");
	     go to EXIT;
	end;

	forward_area_ptr = get_system_free_area_ ();

	on condition (quit)
	     begin;
	     on condition (reissue_query) begin;
		call window_$clear_window (iox_$user_output, (0));
		goto RETRY (opt);
		end;
		if xmail_window_manager_$quit_handler ()
		then do;
		     if restore_menu_needed
		     then call xmail_window_manager_$restore_menu;
		     call ioa_ ("Forwarding terminated.");
		     go to EXIT;
		end;
	     end;

	on condition (cleanup) call CLEAN_UP;

	call xmail_sw_$update_usage (" ");
	call xmail_sw_$redisplay ();
	call window_$clear_window (iox_$user_output, (0));/* ignore error */
	call ioa_$nnl (" ");			/* Position cursor in bottom window */

/*  Create seg for Emacs to place forward address(es) and comment in   */

	forward_seg_name = xmail_data.actee.person || "_fwrd";

	call hcs_$make_seg ("", forward_seg_name, "", RW_ACCESS_BIN, forward_seg_ptr, code);
	if code ^= 0 then do;			/* If seg exists set bit count to zero */
	     bit_count = 0;
	     if code = error_table_$namedup | code = error_table_$segknown
	     then call terminate_file_ (forward_seg_ptr, bit_count, TERM_FILE_BC, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	end;

/* Determine full pathname for emacs seg */

	emacs_seg_path_name = get_pdir_ ();
	emacs_seg_path_name = rtrim (emacs_seg_path_name) || ">" || forward_seg_name;

	for_type = "fwd-comment";
	if ext_ptr = null ()
	then do;
	     call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "", ext_ptr, code);
	     if code ^= 0 then call xmail_error_$no_code
		     (code, NAME, STOP, "^a", PROBLEM);
	     call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT;
	end;

/* Set-up for forwarding */

	recipients_info_n_lists = 2;			/* make room for bcc if needed */
	allocate recipients_info in (forward_area) set (recipients_info_ptr);

	recipients_info.header.version = RECIPIENTS_INFO_VERSION_2;
	recipients_info.header.area_ptr = forward_area_ptr;
	recipients_info.header.n_lists = 1;

	auto_deliver_options.version = DELIVER_OPTIONS_VERSION_2;
	auto_deliver_options.delivery_mode = ORDINARY_DELIVERY;
	auto_deliver_options.queueing_mode = ALWAYS_QUEUE_FOREIGN;
	auto_deliver_options.queued_notification_mode = NOTIFY_ON_ERROR;
	auto_deliver_options.flags.abort = "1"b;
	auto_deliver_options.flags.send_if_empty = "0"b;
	auto_deliver_options.flags.recipient_notification = "1"b;
	auto_deliver_options.flags.queue_mailing_lists = "0"b;

	auto_deliver_options.flags.mbz = "0"b;
	default_save_file = "outgoing";

/* Loop based on the number of messages being forwarded */

	do idx = 1 to curr_msgs.count;
	     message_num = curr_msgs.numbers (idx);
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		call mail_system_$read_message (mailbox_ptr, message_num, code);
		if code ^= 0
		then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
	     end;
	     forward_msg_ptr = mailbox.messages (message_num).message_ptr;
	     message_ptr = forward_msg_ptr;
	     no_chars = 250;
	     based_string = "";
	     based_string = "Forwarding message number " || rtrim (ltrim (char (message_num))) || NL || "Regarding: " || message_subject || NL;
	     bit_count = (length (rtrim (based_string)) + 1) * BITS_PER_CHAR;
	     call terminate_file_ (forward_seg_ptr, bit_count, TERM_FILE_BC, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);


/* Check personalization option to remove and restore menus while editing */

	     if xmail_data.remove_menus
	     then do;
		call xmail_window_manager_$suppress_menu ();
		restore_menu_needed = "1"b;
	     end;

	     call emacs_ (iox_$user_output, (emacs_seg_path_name), ext_pname, addr (for_type), code);

	     if restore_menu_needed
	     then do;
		call xmail_window_manager_$restore_menu ();
		restore_menu_needed = "0"b;
	     end;

	     if code ^= 0
	     then do;
		call xmail_window_manager_$reconnect ();
		call ioa_ ("Message number ^d not forwarded.", message_num);
		if curr_msgs.count > idx
		then do;
RETRY (1):		
		     call ioa_$nnl ("^/Do you still wish to forward message(s): ");
		     do idx1 = idx + 1 to curr_msgs.count;
			message_num1 = curr_msgs.numbers (idx1);
			call ioa_$nnl (" ^d", message_num1);
		     end;				/* end do loop */
		     opt = 1;
		     call xmail_get_str_$yes_no (" ? ", yes_sw);
		     if yes_sw then go to pre_end;
		     else call ioa_ ("Forwarding terminated.");
		end;
		go to EXIT;
	     end;

	     call hcs_$status_mins (forward_seg_ptr, type, bit_count, code);
	     if code ^= 0 then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, ERROR_MESSAGE, message_num);
		call timer_manager_$sleep (3, "11"b);
		go to pre_end;
	     end;

	     if bit_count = 0
	     then do;
		call ioa_ ("Message number ^d not forwarded.", message_num);
		if curr_msgs.count > idx
		then do;
		     call xmail_get_str_$yes_no ((GO_ON), yes_sw);
		     if yes_sw then go to pre_end;
		     else call ioa_ ("Forwarding terminated.");
		end;
		goto EXIT;
	     end;
	     no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0);

/* Get pointer to forwarding recipients address list structure */

	     to_list_ptr = null ();

	     if rtrim (after (before (based_string, "Comment (optional):"), "To:  "), WHITE_SPACE_COMMA) = ""
	     then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, "You did not enter any recipients. Message no. ^d not forwarded.", message_num);
		call timer_manager_$sleep (3, "11"b);
		go to pre_end;
	     end;
	     auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1;
	     auto_parse_text_options.area_ptr = null;
	     auto_parse_text_options.flags.list_errors = "0"b;
	     auto_parse_text_options.flags.validate_addresses = "0"b;
	     auto_parse_text_options.flags.include_invalid_addresses = "0"b;
	     auto_parse_text_options.flags.mbz = "0"b;

	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "Comment (optional):"), "To:  "), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, to_list_ptr, parse_text_error_list_ptr, code);

	     if code ^= 0 then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, ERROR_MESSAGE, message_num);
		call timer_manager_$sleep (3, "11"b);
		go to pre_end;
	     end;

	     recipients_info.area_ptr = get_system_free_area_ ();
	     recipients_info.lists (1).address_list_ptr = to_list_ptr;

	     call xmail_value_$get_with_default (ACKNOWLEDGE, (NO), acknowledge, code);
	     if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG,
		     "An invalid value for ""^a"" was found in the xmail value segment.  Using the default value instead.", ACKNOWLEDGE);

	     if acknowledge = NO
	     then auto_deliver_options.flags.acknowledge = "0"b;
	     else if acknowledge = ASK
	     then do;
RETRY (2):		     
		opt = 2;
		call xmail_get_str_$yes_no ("Do you want your forwarding acknowledged ?  ", yes_sw);
		if yes_sw then auto_deliver_options.flags.acknowledge = "1"b;
		else auto_deliver_options.flags.acknowledge = "0"b;
	     end;
	     else if acknowledge = YES
	     then auto_deliver_options.flags.acknowledge = "1"b;
	     else call xmail_error_$code_first (error_table_$bad_segment, NAME, LOG,
		     "An invalid value for ""^a"" was found in the xmail value segment.  Using the default value instead.", ACKNOWLEDGE);

/* Save the forwarded message? */

	     message_saved = "0"b;
	     dir = xmail_data.mail_dir;

/* Check to see if the message being forwarded should be saved. */

	     call xmail_value_$get (SAVE_MESSAGE, save_message, code);
	     if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG,
		     "An invalid value for ""^a"" was found in the xmail value segment.  Using the default value instead.", SAVE_MESSAGE);

	     if save_message = YES
	     then do;
		ask_again = "0"b;
		opt = 3;
		call prepare_to_save_msg;
		if code ^= 0 then go to pre_end;
	     end;

	     else if save_message = ASK
	     then do;
RETRY (3):		     
		ask_again = "0"b;
		opt = 3;
		call xmail_get_str_$yes_no ("Do you want to save the message being forwarded? ", yes_sw);
		if yes_sw then call prepare_to_save_msg;
		if ask_again then goto RETRY (opt);   /* the user didn't want to create the non-existent file  so start over */
		if code ^= 0 then go to pre_end;
	     end;

	     else if save_message ^= NO
	     then call xmail_error_$code_first (error_table_$bad_segment, NAME, LOG,
		     "An invalid value for ""^a"" was found in the xmail value segment.  Using the default value instead.", SAVE_MESSAGE);

	     call mail_system_$redistribute_message (forward_msg_ptr, ltrim (rtrim (after (based_string, "Comment (optional):"), WHITE_SPACE), WHITE_SPACE), recipients_info_ptr, addr (auto_deliver_options), code);
	     delivery_results_need_cleanup = "1"b;
	     if code ^= 0 then do;
		if code = mlsys_et_$no_a_permission then call xmail_error_$no_code (code, NAME, STOP, "You do not have permission to send message to at least one of the recipients.");
		if n_failed_recipients > 0
		then do;
		     call ioa_ ("Message no.^d could not be forwarded.", message_num);
		     call ssu_$standalone_invocation (sci_ptr, "", "", null (), xmail_forward_msg_$ssu_exit, code1);
		     if code1 = 0 then call mlsys_utils_$print_delivery_results (sci_ptr, ERRORS_ONLY, recipients_info_ptr, code1);
		     else call xmail_error_$no_code (code1, NAME, LOG, "The reason cannot be printed due to an internal programming error");
		     call ssu_$destroy_invocation (sci_ptr);

		     if idx = curr_msgs.count then go to pre_end;

		     resp = "";
		     do while (resp = "");
			call xmail_get_str_ ("^/Press RETURN to continue; BREAK to stop.", "", "", "", resp);
		     end;
		     go to pre_end;
		end;
		call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		call timer_manager_$sleep (4, "11"b);
		go to pre_end;

	     end;

/* Display the recipients */

	     call ioa_ ("Message ^d forwarded to: ", message_num);
	     call mlsys_utils_$print_address_list_field ("To", to_list_ptr, USE_SCREEN_WIDTH, null, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""To:"" recipient(s).");


	     if idx ^= curr_msgs.count then call timer_manager_$sleep (3, "11"b);

pre_end:
	     call MESSAGE_CLEAN_UP ();

	end;					/* end of do loop */

EXIT:	call CLEAN_UP ();

	if xmail_data.remove_menus
	then call xmail_redisplay_$menu;		/* redisplay menu if removed */

	return;

ssu_exit: entry;

/* This entry doesn't do anything but it is called by ssu_$print_message */
/* which is called by mlsys_utils_$print_delivery_results.               */

	return;

/* INTERNAL PROCEDURES */

prepare_to_save_msg: proc ();
dcl savebox_ename char (32);
dcl bcc_address_ptr ptr;
dcl mail_system_$add_address entry (ptr, ptr, char (8), fixed bin (35));

	call xmail_value_$get (SAVE_MAILBOX, default_save_file, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT,
		"An invalid value for ""^a"" was found in the xmail value segment.", SAVE_MAILBOX);

	if default_save_file = ASK then do;
	     call xmail_select_file_ ("mail file", "sv.mbx", "outgoing", ACCEPT_OLD, ACCEPT_NEW, dir, prefix, create, exists, code);
	     if code ^= 0 then go to PREPARE_EXIT;	/* Diagnostic msg already issued by xmail_select_file_. */
	     yes_sw = "0"b;
	     if ^create & ^exists then do;
		call ioa_$rsnnl ("The specified mail file ""^a"" does not exist.^/Do you wish to create it?  ", prompt_string, unused_return_length, prefix);
		call xmail_get_str_$yes_no (prompt_string, yes_sw);
	     end;
	     if create | yes_sw then do;
		call mlsys_utils_$create_savebox (dir, (prefix), code);
		if code ^= 0 then call xmail_error_$code_first (code, NAME, CONTINUE, "Forwarded message not saved due to an internal programming error.");
		else call ioa_ ("The mail file ""^a"" has been created.", prefix);
	     end;
	     else if ^exists
		then do;
		     ask_again = "1"b;
		     goto PREPARE_EXIT;
		     end;
	end;
	else prefix = minus_suffix ((default_save_file), (MAILFILE_SUFFIX));

	if code = 0 then do;
	     call suffixed_name_$make ( (prefix),"sv.mbx",savebox_ename, code);
	     if code ^= 0 then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, ERROR_MESSAGE, message_num);
                    call timer_manager_$sleep (3,"11"b);
		goto pre_end;
		end;
	     call mail_system_$create_address_list (ADDRESS_LIST_VERSION_2, bcc_list_ptr, code);
	     if code ^= 0 then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, ERROR_MESSAGE, message_num);
		call timer_manager_$sleep (3, "11"b);
		go to pre_end;
	     end;
	     call mail_system_$create_savebox_address (xmail_data.actee.person ||"."||xmail_data.actee.project,rtrim (dir),savebox_ename , "", "", bcc_address_ptr, code);
	     if code ^= 0 then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, ERROR_MESSAGE, message_num);
		call timer_manager_$sleep (3, "11"b);
		go to pre_end;
	     end;
	     call mail_system_$add_address (bcc_list_ptr, bcc_address_ptr, ADDRESS_LIST_VERSION_2, code);
	     if code ^= 0 then do;
		call xmail_error_$no_code (code, NAME, CONTINUE, ERROR_MESSAGE, message_num);
		call timer_manager_$sleep (3, "11"b);
		go to pre_end;
	     end;
	     recipients_info.header.n_lists = 2;
	     recipients_info.lists (2).address_list_ptr = bcc_list_ptr;
	     message_saved = "1"b;
	end;

PREPARE_EXIT:
	return;
     end prepare_to_save_msg;

MESSAGE_CLEAN_UP: proc ();

	if to_list_ptr ^= null ()
	then do;
	     call mail_system_$free_address_list (to_list_ptr, code);
	     to_list_ptr = null ();
	end;
	if bcc_list_ptr ^= null ()
	then do;
	     call mail_system_$free_address_list (bcc_list_ptr, code);
	     bcc_list_ptr = null ();
	end;
	if forward_msg_ptr ^= null ()
	then do;
	     call mail_system_$free_message (forward_msg_ptr, code);
	     forward_msg_ptr = null ();
	end;
	if recipients_info_ptr ^= null ()
	then do;
	     if delivery_results_need_cleanup then do;
		call mlsys_utils_$free_delivery_results (recipients_info_ptr, code);
		if code ^= 0 then call xmail_error_$no_print (code, NAME, CONTINUE, "While cleaning up delivery results.");
	     end;
	end;
	return;

     end MESSAGE_CLEAN_UP;

minus_suffix: proc (name, suffix) returns (char (*) var);

/* Parameter */

	dcl     name		 char (*);
	dcl     suffix		 char (*);

/* Automatic */

	dcl     reverse_name	 char (length (name)) var;
	dcl     reverse_suffix	 char (length (suffix)) var;

/* Builtin */

	dcl     (after, index, length, reverse, rtrim) builtin;

	reverse_name = reverse (rtrim (name));
	reverse_suffix = reverse (rtrim (suffix));

	if index (reverse_name, reverse_suffix || ".") ^= 1
	then return (name);
	else return (reverse (after (reverse_name, reverse_suffix || ".")));

     end minus_suffix;

CLEAN_UP: proc ();

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

	call MESSAGE_CLEAN_UP ();
	if forward_seg_ptr ^= null ()
	then call delete_$ptr (forward_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, code);
	if recipients_info_ptr ^= null ()
	then free recipients_info in (forward_area);

	return;
     end CLEAN_UP;

     end xmail_forward_msg_;




		    xmail_get_choice_.pl1           09/02/88  0759.6r w 09/02/88  0745.0      170235



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



/****^  HISTORY COMMENTS:
  1) change(85-12-23,LJAdams), approve(86-03-06,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-08  JG Backs: Modified to add 4 new topics to the general help menu:
     Summary of Function-Escape Keys, User Mailbox, Date Selection, and Deferred
     Messages.  These 4 were added to GEN_HELP_CHOICES.
     85-04-17 JG Backs: Replaced all the Message Facility commands
     (accept_messages, defer_messages, print_messages) with calls to the new
     xmail_im_mgr_ module which uses the new Message Facility entrypoints for
     these functions.
  2) change(85-12-23,LJAdams), approve(86-03-06,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Added check of xmail_data.general_help to determine if General Help is
     being displayed.  Changed "Done with Help" option to actual menu name to
     go to; i.e., "Executive Mail".  "Help" topics are now displayed as a
     separate screen.
  3) change(86-03-06,Blair), approve(86-03-06,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Turn off the flag for cleanup_signalled when we come back to the command
     loop.  If we come back from a cleanup condition, then we know that the
     user did not type rl from multics_mode (pi also comes through the cleanup
     handler where the bit gets set).
                                                   END HISTORY COMMENTS */


/* BEGIN DESCRIPTION

History:         Written in June 81 by Paul Kyzivat 

   83-07-07  DJ Schimke: Removed several unreferenced dcl's and declared
   builtin translate.

   83-09-14  DJ Schimke: Added code to check the value of more_mode for the 
   bottom window before doing the clear_to_end_of_window call. The call to
   clear_to_end_of_window was added for more_mode=wrap (phx11860) and should
   not be done for fold mode. phx12565

   83-10-06  DJ Schimke: Replaced the call to xmail_get_str_ in GEN_HELP with
   a call to xmail_get_str_$yes_no.

   84-09-18  JG Backs: Added uppercase constants for escape sequences in main
   and GET_HELP_CHOICE procedures.

   84-09-24  JG Backs: Added "-brief" control argument to print_messages 
   command so the message "You have no messages" would not print. This is to
   make xmail compatible with the new message facility for mr11.

   84-10-16  JG Backs: Modified GET_HELP_CHOICE proc to allow actual keystrokes
   of function keys or escape sequences in getting help, instead of requiring
   the user to enter the character representations.  Code was lifted from
   xforum to make xmail more compatible with xforum.

END DESCRIPTION
*/

xmail_get_choice_: proc (menu, file, file_info, position, usage, display_needed, initial_help, choice, code);

	accepting_messages = "1"b;
	call MAIN;
	return;

/* ENTRYPOINTS */

dm:  entry (menu, file, file_info, position, usage, display_needed, initial_help, choice, code);

	accepting_messages = "0"b;
	call MAIN;
	return;

/* PARAMETERS */

	dcl     menu		 ptr;
	dcl     file		 char (*);
	dcl     file_info		 char (*);
	dcl     position		 char (*);
	dcl     usage		 char (*);
	dcl     initial_help	 char (*);
	dcl     display_needed	 bit (1) aligned;
	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);


/* AUTOMATIC */

	dcl     redisplay		 bit (1) aligned;
	dcl     fkey		 bit (1) aligned;
	dcl     selected_create	 bit (1) aligned;
	dcl     accepting_messages	 bit (1) aligned;
	dcl     1 auto_mode_value	 automatic like mode_value;
	dcl     mode_str		 char (512);

/* CONSTANTS */

	dcl     COMMAND_LEVEL	 init (8) fixed bin static options (constant);
	dcl     COMMAND_LEVEL_C	 init (15) fixed bin static options (constant);
	dcl     FIRST_MENU		 init (2) fixed bin static options (constant);
	dcl     FIRST_MENU_C	 init (9) fixed bin static options (constant);
	dcl     HELP		 init (1) fixed bin static options (constant);
	dcl     NAME		 init ("xmail_get_choice_") char (17) static options (constant);
	dcl     PREV_MENU		 init (3) fixed bin static options (constant);
	dcl     PREV_MENU_C		 init (10) fixed bin static options (constant);
	dcl     QUIT		 init (4) fixed bin static options (constant);
	dcl     QUIT_C		 init (11) fixed bin static options (constant);
	dcl     REDISPLAY		 init (5) fixed bin static options (constant);
	dcl     REDISPLAY_C		 init (12) fixed bin static options (constant);


/* EXTERNAL STATIC */

	dcl     iox_$user_io	 ptr ext static;
	dcl     iox_$user_output	 ptr ext static;
	dcl     xmail_err_$exit_now	 ext static fixed bin (35);
	dcl     xmail_err_$help_requested ext static fixed bin (35);
	dcl     xmail_err_$gen_help_req ext static fixed bin (35);

/* ENTRIES */

	dcl     continue_to_signal_	 entry (fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$modes		 entry (ptr, char (*), char (*), fixed bin (35));
	dcl     mode_string_$get_mode	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_im_mgr_$accept_messages	 entry ();
	dcl     xmail_im_mgr_$defer_messages	 entry ();
	dcl     xmail_redisplay_$all	 entry ();
	dcl     xmail_multics_mode_	 entry ();
	dcl     xmail_error_$code_last entry options (variable);
	dcl     xmail_sw_$update_file	 entry (char (*));
	dcl     xmail_sw_$update_file_info entry (char (*));
	dcl     xmail_sw_$update_position entry (char (*));
	dcl     xmail_sw_$update_usage entry (char (*));
	dcl     xmail_sw_$redisplay	 entry();
	dcl     xmail_redisplay_$menu	entry options(variable);
	
/* BUILTINS */

	dcl     (addr, null) builtin;

/* CONDITIONS */

	dcl     (cleanup, xmail_leave_menu, quit) condition;

/* INCLUDE FILES */

%include function_key_data;
%page;
%include xmail_data;
%page;
%include xmail_windows;
%page;
%include menu_dcls;
%page;
%include window_dcls;
%page;
%include xmail_help_infos;
%page;
%include xmail_responses;
%page;
%include mode_string_info;

/* BEGIN */

MAIN: proc;

	on condition (cleanup) begin;
		if accepting_messages & xmail_data.interactive_msgs
		then call xmail_im_mgr_$defer_messages;
		xmail_data.general_help = "0"b;
	     end;

	code = 0;
	redisplay = display_needed;

	call xmail_sw_$update_file (file);
	call xmail_sw_$update_file_info (file_info);
	call xmail_sw_$update_position (position);
	call xmail_sw_$update_usage (usage);
	call xmail_sw_$redisplay ();

	do while (code = 0);
               if redisplay then call DISPLAY (code);
	     if code ^= 0 then go to ERROR;
	     xmail_data.cleanup_signalled = "0"b;        /* in case we came back from cleanup */
	     redisplay = "0"b;

	     if accepting_messages & xmail_data.interactive_msgs
	     then	call xmail_im_mgr_$accept_messages;

	     call iox_$modes (xmail_windows.bottom.iocb, "", mode_str, code);
	     if code ^= 0 then go to ERROR;
	     auto_mode_value.version = mode_value_version_3;
	     call mode_string_$get_mode (mode_str, "more_mode", addr (auto_mode_value), code);
	     if code ^= 0 then go to ERROR;
	     if auto_mode_value.char_value ^= "fold" then
		call window_$clear_to_end_of_window (xmail_windows.bottom.iocb, (0));

	     call menu_$get_choice (
		xmail_windows.menu.iocb,
		menu,
		xmail_data.function_key_data_ptr,
		fkey,
		choice,
		code);
	     if code ^= 0 then go to ERROR;

	     if accepting_messages & xmail_data.interactive_msgs
	     then call xmail_im_mgr_$defer_messages;

	     /*** user must have read bottom window by now ***/
	     call iox_$control (iox_$user_io, "reset_more", null, (0));

	     if ^fkey
	     then go to EXIT;

	     if choice = HELP
	     then do;
	          call GET_HELP;
		call xmail_sw_$update_usage (usage);
		call xmail_sw_$redisplay();
	     end;
	     else if choice = PREV_MENU | choice = PREV_MENU_C
	     then do;
		call window_$clear_window (iox_$user_output, (0));
		code = xmail_err_$exit_now;
	     end;
	     else if choice = FIRST_MENU | choice = FIRST_MENU_C
	     then do;
		call window_$clear_window (iox_$user_output, (0));
		signal xmail_leave_menu;
		goto xmail_data.first_label;
	     end;
	     else if choice = QUIT | choice = QUIT_C
	     then do;
		call window_$clear_window (iox_$user_output, (0));
		signal xmail_leave_menu;
		goto xmail_data.quit_label;
	     end;
	     else if choice = REDISPLAY | choice = REDISPLAY_C
	     then call xmail_redisplay_$all ();
	     else if (choice = COMMAND_LEVEL) & (xmail_data.multics_mode)
	     then call xmail_multics_mode_;
	     else if (choice = COMMAND_LEVEL_C) & (xmail_data.multics_mode)
	     then call xmail_multics_mode_;
	     else call window_$bell (xmail_windows.menu.iocb, (0));
	end;
	go to EXIT;

ERROR:	call xmail_error_$code_last (code, NAME, "s",
	     "A program error has occurred for which no " ||
	     "automatic correction is known.");

EXIT:	return;
     end MAIN;

/* INTERNAL PROCEDURES */

GET_HELP: proc;

	dcl     FUNCTION_KEY_INFO	 init ("xmail_function_keys.gi") char (22)
				 static options (constant);

	dcl     info_name		 char (2);

	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35)),
	        xmail_error_$code_first entry () options (variable),
	        ioa_$rsnnl		 entry () options (variable);


	call GET_HELP_CHOICE (fkey, choice, code);
	if code = xmail_err_$gen_help_req
	then do;
	     code = 0;
	     call GEN_HELP ();
	end;
	else if code ^= 0 then go to GH_EXIT;
	else do;

	     call window_$clear_window (iox_$user_output, (0));

	     if fkey then do;
		call ioa_$rsnnl ("F^d", info_name, (0), choice);
		call xmail_display_help_ (FUNCTION_KEY_INFO, info_name, code);
		if code ^= 0
		then call xmail_error_$code_first (code, NAME, "l", "Function Key ^d", choice);
		code = 0;
	     end;
	     else code = xmail_err_$help_requested;
	end;
GH_EXIT:
          xmail_data.general_help = "0"b;
	return;

     end GET_HELP;

GET_HELP_CHOICE: proc (ghc_fkey, ghc_choice, ghc_code);

/* PARAMETERS */

	dcl     ghc_code		 fixed bin (35);	/* output */
	dcl     ghc_choice		 fixed bin;	/* output */
	dcl     ghc_fkey		 bit (1) aligned;	/* output */

/* AUTOMATIC */

	dcl     ghc_highest		 fixed bin;
	dcl     ghc_prompt		 char (256) var;
	dcl     ghc_special_fkey_data_ptr ptr;
	dcl     ghc_special_fkey_data_sequence_seq_len fixed bin;
	dcl     ghc_special_fkey_seqs_ptr ptr;

/* BUILTINS */

	dcl     (index)                builtin;

/* EXTERNAL STATIC */

	dcl     xmail_err_$invalid_response ext static fixed bin (35);

/* ENTRIES */

	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);

/* BASED */

	dcl     ghc_special_fkey_seqs	 char (ghc_special_fkey_data_sequence_seq_len) based (ghc_special_fkey_seqs_ptr);

/* BEGIN GET_HELP_CHOICE */

	ghc_code = 0;
	ghc_special_fkey_data_ptr = null ();
	ghc_special_fkey_seqs_ptr = null ();
	function_key_data_ptr = xmail_data.function_key_data_ptr;

	on condition (cleanup) call CLEANUP;

	on condition (quit)
	     begin;
		call CLEANUP;
		call continue_to_signal_ ((0));
	     end;

	call window_$clear_window (iox_$user_output, (0));

	call ioa_$rsnnl ("Press the option or "
	     || "^[function key ^;"
	     || "escape sequence ^] "
	     || "for which you want help ^/  (or ?? for a menu of general help topics):",
	     ghc_prompt, (0), (index (xmail_data.normal_usage, "ESC") = 0));

	call ioa_ (ghc_prompt);

	function_key_data_highest = function_key_data_ptr -> function_key_data.highest + 1;
	ghc_highest = function_key_data_highest;

	allocate function_key_data set (ghc_special_fkey_data_ptr);

	ghc_special_fkey_data_ptr -> function_key_data.highest = ghc_highest - 1;
	ghc_special_fkey_data_ptr -> function_key_data = function_key_data_ptr -> function_key_data;
	ghc_special_fkey_data_ptr -> function_key_data.highest = ghc_highest;

	ghc_special_fkey_data_ptr -> function_key_data.sequence.seq_len = ghc_special_fkey_data_ptr -> function_key_data.sequence.seq_len + 2;
	ghc_special_fkey_data_sequence_seq_len = ghc_special_fkey_data_ptr -> function_key_data.sequence.seq_len;

	allocate ghc_special_fkey_seqs;

	ghc_special_fkey_seqs = function_key_seqs || "??";
	ghc_special_fkey_data_ptr -> function_key_data.function_keys (ghc_highest, KEY_PLAIN).sequence_index = ghc_special_fkey_data_sequence_seq_len - 1;
	ghc_special_fkey_data_ptr -> function_key_data.function_keys.sequence_length = 2;
	ghc_special_fkey_data_ptr -> function_key_data.sequence.seq_ptr = ghc_special_fkey_seqs_ptr;

	call menu_$get_choice (
	     xmail_windows.menu.iocb,
	     menu,
	     ghc_special_fkey_data_ptr,
	     ghc_fkey,
	     ghc_choice,
	     ghc_code);

	if ghc_code ^= 0				/* error */
	then go to GHC_EXIT;

	if ^ghc_fkey				/* option number */
	then go to GHC_EXIT;

	if ghc_choice = ghc_highest			/* ?? answer */
	then do;
	     ghc_code = xmail_err_$gen_help_req;
	     go to GHC_EXIT;
	end;

	else if ghc_choice < 9			/* first 8 choices ok */
	then go to GHC_EXIT;

	if index (xmail_data.normal_usage, "ESC") = 0

	then do;					/* function key > 8 */
	     call ioa_ ("Function key F^d has no function within Executive Mail", ghc_choice);
	     ghc_code = xmail_err_$invalid_response;
	     go to GHC_EXIT;
	end;

/* Now check for escape sequences with capital letters and switch */

	else
	     if ghc_choice = 9
	then ghc_choice = 2;
	else
	     if ghc_choice = 10
	then ghc_choice = 3;
	else
	     if ghc_choice = 11
	then ghc_choice = 4;
	else
	     if ghc_choice = 12
	then ghc_choice = 5;
	else
	     if ghc_choice = 13
	then ghc_choice = 6;
	else
	     if ghc_choice = 14
	then ghc_choice = 7;
	else
	     if ghc_choice = 15
	then ghc_choice = 8;

	else do;
	     call ioa_ ("Escape sequence has no function within Executive Mail", ghc_choice);
	     ghc_code = xmail_err_$invalid_response;
	end;

GHC_EXIT:
	call CLEANUP;
	return;

CLEANUP: proc ();

        	if ghc_special_fkey_data_ptr ^= null ()
	then free ghc_special_fkey_data_ptr -> function_key_data.sequence.seq_ptr -> ghc_special_fkey_seqs;

	if ghc_special_fkey_seqs_ptr ^= null ()
	then free ghc_special_fkey_data_ptr -> function_key_data;

     end CLEANUP;

     end GET_HELP_CHOICE;

GEN_HELP: proc ();

	dcl     GEN_HELP_CHOICES	 dim (1:20) char (31) int static options (constant)init
                                        ("Exiting Executive Mail",
				 "Function Keys",
				 "Summary of Function-Escape Keys",
				 "Help With a Prompt",
				 "Editing Mail",
				 "Summary of Editor Requests",
				 "Retrieving Erased Text",
				 "Right Margins",
				 "BREAK Key",
				 "Mail Files",
				 "User Mailbox",
				 "Current Messages",
				 "Selecting Messages",
				 "Keywords",
				 "Specifying Ranges",
				 "Searching Messages",
				 "Date Selection",
				 "Scrolling",
				 "User Names",
				 "Deferred Messages") aligned var;

	dcl     choice		 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     gen_help_menup	 ptr init (null) int static;
	dcl     yes_sw		 bit (1) aligned;

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     xmail_dyn_menu_$create_w_trailer entry ((*) char (*) aligned, char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_get_dyn_choice_$trailer entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_window_manager_$reconnect
				entry options(variable);
	dcl     xmail_window_manager_$suppress_menu
				entry options(variable);
	dcl     xmail_window_manager_$restore_menu 
				entry options(variable);

	dcl     (null, translate)	builtin;

	on condition (quit)
	   begin;
	   call xmail_window_manager_$reconnect;
	   goto GEN_HELP_EXIT;
	   end;
	
          xmail_data.general_help = "1"b;

	if gen_help_menup = null
	then do;
	     call xmail_dyn_menu_$create_w_trailer ((GEN_HELP_CHOICES), "<Executive Mail>", gen_help_menup, null, get_system_free_area_ (), code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, NAME, "q", "Unable to create general help menu. This is an internal programming error.");
	end;

	do while ("1"b);
	     call xmail_window_manager_$suppress_menu ();
	     call xmail_get_dyn_choice_$trailer (gen_help_menup, choice, selected_create, code);
	     if selected_create then
	        go to GEN_HELP_EXIT;
	     if code ^= 0
	     then call xmail_error_$no_code (code, NAME, "q", "Unable to get general help choice. This is an internal programming error.");
	     call xmail_display_help_ (GENERAL_HELP_HELP, translate (GEN_HELP_CHOICES (choice), "_", " "), code);
	     if code ^= 0
	     then call xmail_error_$no_print (code, NAME, "l", "Unable to get help. This is an internal programming error.");
	     call xmail_get_str_$yes_no ("More help?", yes_sw);
	     if ^yes_sw then go to GEN_HELP_EXIT;
	end;

GEN_HELP_EXIT:
          call xmail_window_manager_$restore_menu ();
	call xmail_redisplay_$menu ();
	return;
     end GEN_HELP;

DISPLAY: proc (code);

	dcl     1 actual_menu_rqmts	 aligned like menu_requirements;

	dcl     xmail_err_$insuff_room_for_window ext static fixed bin (35);

	dcl     xmail_window_manager_$set_menu_window_size entry (fixed bin, fixed bin (35));
	dcl     xmail_window_manager_$set_sw_size entry (fixed bin, fixed bin (35));
	dcl     xmail_redisplay_$status_window entry ();
	dcl     xmail_redisplay_$menu	 entry ();

	dcl     (addr)		 builtin;
	dcl     code		 fixed bin (35);

	actual_menu_rqmts.version = menu_requirements_version_1;
	call menu_$describe (menu, addr (actual_menu_rqmts), code);
	if code ^= 0 then goto DISPLAY_EXIT;

	if actual_menu_rqmts.width_needed > xmail_windows.menu.width
	then code = xmail_err_$insuff_room_for_window;
	else do;
	     if position = ""
	     then call xmail_window_manager_$set_sw_size (1, code);
	     else call xmail_window_manager_$set_sw_size (2, code);
	     if code = 0
	     then do;
		call xmail_redisplay_$status_window ();
		call xmail_window_manager_$set_menu_window_size
		     (actual_menu_rqmts.lines_needed, code);
	     end;
	     if code = 0
	     then do;
		call xmail_redisplay_$menu ();
		if initial_help ^= ""
		then do;
		     call window_$clear_window (iox_$user_output, (0));
		     call xmail_display_help_ (initial_help, "", (0));
		end;
	     end;
	end;
DISPLAY_EXIT:
	return;

     end DISPLAY;

     end xmail_get_choice_;




		    xmail_get_dyn_choice_.pl1       09/02/88  0759.6r w 09/02/88  0748.4       34911



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


xmail_get_dyn_choice_: proc (P_dyn_menup, P_index, P_code);

/* Author unknown

   83-07-07  DJ Schimke: Removed unreferenced dcl of FIRST_MENU, HELP, 
   PREV_MENU, QUIT.
*/

/* Parameter */

	dcl     P_code		 fixed bin (35);
	dcl     P_dyn_menup		 ptr;
	dcl     P_index		 fixed bin;
	dcl     P_trailer		 bit (1) aligned;

/* Automatic */

	dcl     choice		 fixed bin;
	dcl     fkey		 bit (1) aligned;
	dcl     menu_index		 fixed bin;
	dcl     n_trailers		 fixed bin;
	dcl     option_index	 fixed bin;
	dcl     total_options	 fixed bin;
	dcl     trailer_included	 bit (1) aligned;

	dcl     1 auto_dyn_menu_req	 like dyn_menu_req;

/* Entries */

	dcl     window_$bell	 entry (ptr, fixed bin (35));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     xmail_dyn_menu_$display entry (ptr, fixed bin, fixed bin (35));
	dcl     xmail_dyn_menu_$get_choice entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     xmail_dyn_menu_$info	 entry (ptr, ptr, fixed bin (35));
	dcl     xmail_redisplay_$all	 entry options (variable);

/* Constant */

	dcl     REDISPLAY		 init (5) fixed bin int static options (constant);
	dcl     SCROLL_UP		 init (7) fixed bin int static options (constant);
	dcl     SCROLL_DOWN		 init (6) fixed bin int static options (constant);

/* Builtin */

	dcl     (addr, divide, mod)	 builtin;

	trailer_included = "0"b;
	call MAIN;
	return;

trailer: entry (P_dyn_menup, P_index, P_trailer, P_code);

	trailer_included = "1"b;
	call MAIN;
	return;

MAIN: proc ();
	call xmail_dyn_menu_$info (P_dyn_menup, addr (auto_dyn_menu_req), P_code);
	if P_code ^= 0 then go to EXIT;

	menu_index = 0;

	do while ("1"b);
	     call xmail_dyn_menu_$display (P_dyn_menup, menu_index, P_code);
	     if P_code ^= 0 then go to EXIT;
	     call xmail_dyn_menu_$get_choice (P_dyn_menup, menu_index, choice, fkey, P_code);
	     if P_code ^= 0 then go to EXIT;
	     if ^fkey
	     then do;
		option_index = menu_index * auto_dyn_menu_req.options_per_menu + choice;
		if ^trailer_included
		then do;
		     P_index = option_index;
		     go to EXIT;
		end;
		total_options = auto_dyn_menu_req.options_per_menu * (auto_dyn_menu_req.n_menus - 1) + auto_dyn_menu_req.options_last_menu;
		if option_index = total_options
		then do;				/* trailer opt selected */
		     P_index = 0;
		     P_trailer = "1"b;
		     go to EXIT;
		end;
		if mod (option_index, auto_dyn_menu_req.options_per_menu) = 0
		then do;				/* trailer opt selected */
		     P_index = 0;
		     P_trailer = "1"b;
		     go to EXIT;
		end;
						/* regular opt selected */
		n_trailers = divide (option_index, auto_dyn_menu_req.options_per_menu, 17, 0);
		P_index = option_index - n_trailers;
		P_trailer = "0"b;
		go to EXIT;
	     end;
	     else if choice = REDISPLAY
	     then call xmail_redisplay_$all ();
	     else if choice = SCROLL_UP
	     then menu_index = mod (menu_index + 1, auto_dyn_menu_req.n_menus);
	     else if choice = SCROLL_DOWN
	     then menu_index = mod (menu_index - 1, auto_dyn_menu_req.n_menus);
	     else call window_$bell (xmail_windows.bottom.iocb, (0)); /* ignore code */
	end;					/* do while ...*/

EXIT:

	call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */
     end MAIN;

%page;
%include xmail_data;
%page;
%include xmail_windows;
%page;
%include xmail_dyn_menu_dcls;

     end xmail_get_dyn_choice_;




		    xmail_get_str_.pl1              05/26/87  1233.8rew 05/26/87  1221.4       68391



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




/****^  HISTORY COMMENTS:
  1) change(87-04-17,Blair), approve(87-04-22,MCR7683),
     audit(87-05-15,RBarstad), install(87-05-26,MR12.1-1037):
     Enable the cp_escape for command_query_ which is called whever we need an
     answer from the user.  Previously disabled.  TR 20776.
                                                   END HISTORY COMMENTS */


xmail_get_str_: proc (P_prompt, P_acceptable_answers, P_help_file, P_info, P_str);

/* Author unknown

   83-10-03 Dave Schimke: Added yes_no entry point to simplify and standardize
   calls that want only yes or no answers.

*/

/* Parameters */

	dcl     P_acceptable_answers	 (*) char (*) var parameter;
	dcl     P_help_file		 char (*) parameter;
	dcl     P_info		 char (*) parameter;
	dcl     P_prompt		 char (*) var parameter;
	dcl     P_str		 char (*) var parameter;
	dcl     P_yes_sw		 bit (1) aligned parameter;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This is the main entry of xmail_get_str_. It prompts the user for input using        */
/* P_prompt and accepts only answers from P_acceptable_answers. If a question	        */
/* mark is input, the section P_info of P_help_file is displayed for the user	        */
/* by a call to xmail_display_help_. The user response is given by P_str.	        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	call main (P_prompt, P_acceptable_answers, P_help_file, P_info, NOT_ONLY_YES_OR_NO, P_str);
	return;

nl:  entry (P_prompt, P_acceptable_answers, P_help_file, P_info, P_str);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry performs exactly like the above main entry except that it also	        */
/* puts out a new_line and does a reset more before prompting the user.	        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	call iox_$control (iox_$user_output, "reset_more", null, (0));
	call ioa_$nnl ("^/");
	call main (P_prompt, P_acceptable_answers, P_help_file, P_info, NOT_ONLY_YES_OR_NO, P_str);
	return;

yes_no: entry (P_prompt, P_yes_sw);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This is a special simplified entry for callers who want to restrict the user to yes  */
/* or no answers.  It prompts the user with P_prompt and returns either true (yes) or   */
/* false (no) in P_yes_sw.  It accepts yes, no, y, or n.  Help files are not supplied   */
/* to the main procedure here because command_query takes care of the "?" response      */
/* itself and never passes it back.					        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	call main (P_prompt, "", "", "", ONLY_YES_OR_NO, yes_or_no_string);
	if yes_or_no_string = YES | yes_or_no_string = Y
	then P_yes_sw = "1"b;
	else P_yes_sw = "0"b;
	return;

main: proc (I_prompt, I_acceptable_answers, I_help_file, I_info, I_yes_or_no_sw, O_str);

	dcl     I_prompt		 char (*) var parameter;
	dcl     I_acceptable_answers	 (*) char (*) var parameter;
	dcl     I_help_file		 char (*) parameter;
	dcl     I_info		 char (*) parameter;
	dcl     I_yes_or_no_sw	 bit (1) aligned parameter;
	dcl     O_str		 char (*) var parameter;

	dcl     line		 char (maxlength (O_str)) var;
	dcl     outline		 char (maxlength (O_str));

	O_str = "";				/* Initialize output parameter */

	if I_acceptable_answers (1) = ""
	then accept_anything = "1"b;
	else accept_anything = "0"b;

	auto_query_info.version = query_info_version_6;
	auto_query_info.switches.yes_or_no_sw = I_yes_or_no_sw;
	auto_query_info.switches.suppress_name_sw = "1"b;
	auto_query_info.switches.cp_escape_control = ENABLE_ESCAPE;
	auto_query_info.switches.suppress_spacing = "1"b;
	auto_query_info.switches.literal_sw = "0"b;
	auto_query_info.switches.prompt_after_explanation = "0"b;
	auto_query_info.switches.padding = "0"b;
	auto_query_info.status_code = 0;
	auto_query_info.query_code = 0;
	auto_query_info.question_iocbp = null ();	/* default: user_i/o */
	auto_query_info.answer_iocbp = null ();		/* default: user_input */
	auto_query_info.repeat_time = 0;		/* don't repeat */
	auto_query_info.explanation_ptr = null ();
	auto_query_info.explanation_len = 0;

	been_thru_this_before = "0"b;
	do while ("1"b);
	     call iox_$control (iox_$user_output, "reset_more", null, (0)); /* ignore code */

	     call command_query_ (addr (auto_query_info), line, "", "^[^/^]^a^2x", been_thru_this_before, I_prompt);
	     been_thru_this_before = "1"b;

	     if line = QUESTION
	     then do;
		     if I_help_file = ""
		     then call ioa_ ("^/There is no help available for this prompt.");
		     else do;
			     call ioa_$nnl ("^/");
			     call xmail_display_help_ (I_help_file, I_info, code);
			     if code ^= 0
			     then call xmail_error_$no_print (code, ME_CHAR, "l", "Unable to display help. This is an internal programming error.");
			end;
		end;
	     else do;
		     if accept_anything
		     then do;
			     O_str = line;
			     go to EXIT;
			end;
		     else do i = lbound (I_acceptable_answers, 1) to hbound (I_acceptable_answers, 1);
			     if line = I_acceptable_answers (i)
			     then do;
				     O_str = line;
				     go to EXIT;
				end;
			end;
		     outline = line;
		     call ioa_ ("^/""^a"" is not an acceptable response.^/Please reenter^[ or type ""?"" for help^].", outline, (I_help_file ^= ""));
		end;
	end;					/* do while */

EXIT:	return;
     end main;

/* Automatic */

	dcl     accept_anything	 bit (1) aligned;
	dcl     been_thru_this_before	 bit (1) aligned;
	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     yes_or_no_string	 char (3) var;
	dcl     1 auto_query_info	 like query_info;

/* Entries */

	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     command_query_	 entry () options (variable);
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$no_print	 entry () options (variable);

/* External Static */

	dcl     iox_$user_output	 ptr ext static;

/* Constants */

	dcl     ENABLE_ESCAPE	 bit (2) aligned init ("11"b) int static options (constant);
	dcl     ME_CHAR		 char (14) init ("xmail_get_str_") int static options (constant);
	dcl     ONLY_YES_OR_NO	 bit (1) aligned init ("1"b) int static options (constant);
	dcl     NOT_ONLY_YES_OR_NO	 bit (1) aligned init ("0"b) int static options (constant);

/* Builtin */

	dcl     (addr, hbound, lbound, maxlength, null) builtin;

%include query_info;
%page;
%include xmail_help_infos;
%page;
%include xmail_responses;

     end xmail_get_str_;




		    xmail_im_mgr_.pl1               05/31/88  1526.9rew 05/31/88  1500.7      139212



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


/****^  HISTORY COMMENTS:
  1) change(86-02-27,Blair), approve(86-02-27,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
      85-04-15 JG Backs: Written from xforum_im_mgr.pl1
     
      85-04-17 JG Backs: Added a print_messages entry to allow for restoring
      original without printing messages in the case of restore_original
      being called during a cleanup condition.  Deleted the call to
      print_unseen_messages from restore_original entry.
     
      85-04-23 JG Backs: Cleanup code for standards.
  2) change(86-06-04,Blair), approve(86-07-15,MCR7447),
     audit(86-07-18,LJAdams), install(86-07-21,MR12.0-1100):
     Delete xim_defer_message structure, have defer_messages always set things
     up with the accept_messages structure and use dummy wakeup_handler entries
     to take advantage of message_facility_ changes which make processing
     faster.
  3) change(88-04-06,Blair), approve(88-05-02,MCR7882),
     audit(88-05-13,LJAdams), install(88-05-31,MR12.2-1050):
     Make the print_unseen_messages routine call xmail_area_$create to define
     the area that the msg_array structure will be placed in.
                                                   END HISTORY COMMENTS */

xmail_im_mgr: proc;

/*
   BEGIN DESCRIPTION

   function:
      This module manages interactive message handling for the Executive Mail
      subsystem.

   description of entry points:
      xmail_im_mgr: This entry point should never be called.

      init: This entry obtains a pointer to the msg_facility_mailbox structure
      to the users default mailbox (>udd>PROJECT_ID>PERSON_ID>PERSON_ID.mbx.
      It also records the message handling state of that mailbox and sets the 
      message handling states for the xmail message handling accept and
      defer states. This entry must be called before any other entry in this
      module. Note that if the original_wakeup_flags = "0"b it means that
      messages have never been accepted. There is a ring 1 restriction
      that prevents the wakeup_state_flags from being reset to "0"b once they
      have been set to something else. Because of this the original
      wakeup_state_flags will be changed to "72"b3 (defer messages) if they
      are "0"b

      accept_messages: This entry changes the message handling state of the
      users default mailbox to the Executive Mail accept messages state.
      This state looks like the system standard accept message state except
      that all messages are held. It will also print out all unseen messages
      by calling the print_unseen_messages procedure.

      defer_messages: This entry changes the message handling state to the
      Executive Mail defer messages state. This state looks like the system
      standard defer message state.

      restore_original: This entry will change the message handling
      state to the state it was in before the call to the init entry.
      If not a cleanup condition, a call to the print_messages entrypoint
      should be made before calling this entrypoint.

      print_messages: This entry will print out all unseen messages by
      calling the print_unseen_messages procedure.

   description of internal procedures:
      set_message_facility_data: Given a structure that defines a message
      handling state this procedure calls the appropriate message_facility
      entry points to set that state.

      print_unseen_messages: This procedure causes all unseen messages to be
      printed over user_io. It then marks those messages as printed. In the
      event of an error while printing a message an error message is output and
      printing of other unseen messages is aborted.  This procedure uses
      the message_facility entrypoints.

      print_error: This procedure will print an error message explaining that
      an error occurred while printing messages and that the messages may be
      read after Xmail is exited. A timer puts the process to sleep for 4
      seconds so that the message may be read.
      
      error: This procedure will call xmail_error_ with "quit" action after 
      logging the error.  It will be called if an error is returned from one
      of the message_facility_ calls. It will also be called if the main
      entry point xmail_im_mgr$xmail_im_mgr is called.

   known bugs:

   notes:

   END DESCRIPTION
*/

/* PARAMETERS */

/* EXTERNAL STATIC */

	dcl     iox_$user_io	 ptr ext static;

/* ENTRIES */

	dcl     ioa_		 entry () options (variable);
	dcl     message_facility_$get_alarm_handler entry (ptr, entry, ptr, fixed bin (71), fixed bin (35));
	dcl     message_facility_$get_message_format entry (ptr, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35));
	dcl     message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35));
	dcl     message_facility_$get_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$get_wakeup_handler entry (ptr, entry, ptr, fixed bin (35));
	dcl     message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35));
	dcl     message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35));
	dcl     message_facility_$set_alarm_handler entry (ptr, entry, ptr, fixed bin (71), fixed bin (35));
	dcl     message_facility_$set_message_format entry (ptr, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$set_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35));
	dcl     message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35));
	dcl     message_facility_$set_wakeup_handler entry (ptr, entry, ptr, fixed bin (35));
	dcl     message_facility_$set_wakeup_state entry (ptr, bit (*), fixed bin (35));
	dcl     xmail_im_mgr_$dummy    entry ();
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     user_info_		 entry (char (*), char (*), char (*));

/* CONDITIONS */

/* INTERNAL AUTOMATIC */

/* INTERNAL STATIC */

	dcl     first_time             bit (1) aligned init ("1"b) internal static;
          dcl     pum_work_area_ptr      ptr;
	dcl     (
	        xim_msg_facility_mbx_ptr ptr,
	        01 xim_accept_messages like message_facility_data,
	        01 xim_original	 like message_facility_data
	        )			 internal static;

/* CONSTANTS */

	dcl     NAME                   char (13) init ("xmail_im_mgr_") internal static options (constant);
	dcl     QUIT                   char (1) init ("q") internal static options (constant);
	dcl     xim_512_SPACES	 char (512) init (" ") internal static options (constant);

/* BUILTINS */

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

/* BASED */

	dcl     01 message_facility_data based,
		02 wakeup_state_flags bit (36),
		02 prefix_string	 char (32) varying,
		02 short_prefix	 bit (1) aligned,
		02 short_format	 bit (1) aligned,
		02 alarm_entry	 entry,
		02 alarm_info_ptr	 ptr,
		02 alarm_time	 fixed bin (71),
		02 wakeup_entry	 entry,
		02 wakeup_info_ptr	 ptr;


/* INCLUDE FILES */

%include msg_array;
%page;
%include msg_print_flags;

/* BEGIN */

	call error (0, "Program logic error, main entry point in xmail_im_mgr called.");

/* ENTRYPOINTS */

init: entry ();

/* AUTOMATIC */

	dcl     i_code		 fixed bin (35);
	dcl     i_dir		 char (168) varying;
	dcl     i_entry		 char (32);
	dcl     i_user_name		 char (32);
	dcl     i_user_project	 char (32);
	dcl     i_unused_c32	 char (32);

/* BEGIN */

	call user_info_ (i_user_name, i_user_project, i_unused_c32);
	i_dir = ">udd>" || rtrim (i_user_project);
	i_dir = i_dir || ">";
	i_dir = i_dir || rtrim (i_user_name);
	i_entry = rtrim (i_user_name) || ".mbx";

	call message_facility_$get_msgf_mbx_ptr ((i_dir), i_entry, xim_msg_facility_mbx_ptr, i_code);
	if i_code ^= 0
	then call error (i_code, "Could not get msg facility mbx ptr.");

	call message_facility_$get_wakeup_state (xim_msg_facility_mbx_ptr, xim_original.wakeup_state_flags, i_code);
	if i_code ^= 0
	then call error (i_code, "Could not get original wakeup state.");

	call message_facility_$get_prefix (xim_msg_facility_mbx_ptr,
	     xim_original.prefix_string, xim_original.short_prefix, i_code);
	if i_code ^= 0
	then call error (i_code, "Could not get original msg prefix information.");

	call message_facility_$get_message_format (xim_msg_facility_mbx_ptr, xim_original.short_format, i_code);
	if i_code ^= 0
	then call error (i_code, "Could not get original short format flag.");

	call message_facility_$get_alarm_handler (xim_msg_facility_mbx_ptr,
	     xim_original.alarm_entry, xim_original.alarm_info_ptr, xim_original.alarm_time, i_code);
	if i_code ^= 0
	then call error (i_code, "Could not get original alarm handler information.");

	call message_facility_$get_wakeup_handler (xim_msg_facility_mbx_ptr,
	     xim_original.wakeup_entry, xim_original.wakeup_info_ptr, i_code);
	if i_code ^= 0
	then call error (i_code, "Could not get original wakeup handler information.");

	if xim_original.wakeup_state_flags = "0"b
	then xim_original.wakeup_state_flags = "72"b3;

	xim_accept_messages.wakeup_state_flags = "74"b3;
	xim_accept_messages.prefix_string = "";
	xim_accept_messages.short_prefix = "0"b;
	xim_accept_messages.short_format = "0"b;
	xim_accept_messages.alarm_entry = xmail_im_mgr_$dummy;
	xim_accept_messages.alarm_info_ptr = null ();
	xim_accept_messages.alarm_time = 0;
	xim_accept_messages.wakeup_entry = xmail_im_mgr_$dummy;
	xim_accept_messages.wakeup_info_ptr = addr (xim_512_SPACES);

/* in case state changed during multics mode */
	if ^first_time 
	then if substr(xim_original.wakeup_state_flags,4,2) = "10"b
	     then xim_accept_messages.wakeup_state_flags = xim_original.wakeup_state_flags;
	     else xim_accept_messages.wakeup_state_flags = "74"b3;
	return;

accept_messages: entry ();

	if first_time then do;
	     xim_accept_messages.wakeup_state_flags = "74"b3;
	     first_time = "0"b;
	     end;
	else if substr(xim_original.wakeup_state_flags,4,2) = "01"b
	     then xim_accept_messages.wakeup_state_flags = "74"b3;
	     else xim_accept_messages.wakeup_state_flags = xim_original.wakeup_state_flags;
	call set_message_facility_data (xim_accept_messages);
	call print_unseen_messages;

	return;

dummy: entry ();
	return;

defer_messages: entry ();

	call set_message_facility_data (xim_accept_messages);

	return;

print_messages: entry ();

	call print_unseen_messages;

	return;

restore_original: entry ();

	call set_message_facility_data (xim_original);

	return;

/* INTERNAL PROCEDURES */

set_message_facility_data: proc (smfd_message_facility_data);

/* PARAMETERS */

	dcl     01 smfd_message_facility_data like message_facility_data;

/* AUTOMATIC */

	dcl     smfd_code		 fixed bin (35);

/* BEGIN */

	call message_facility_$set_wakeup_state (xim_msg_facility_mbx_ptr,
	     smfd_message_facility_data.wakeup_state_flags, smfd_code);
	if smfd_code ^= 0
	then call error (smfd_code, "Could not set xmail accept wakeup state.");

	call message_facility_$set_prefix (xim_msg_facility_mbx_ptr,
	     smfd_message_facility_data.prefix_string, smfd_message_facility_data.short_prefix, smfd_code);
	if smfd_code ^= 0
	then call error (smfd_code, "Could not set xmail accept msg prefix information.");

	call message_facility_$set_message_format (xim_msg_facility_mbx_ptr,
	     smfd_message_facility_data.short_format, smfd_code);
	if smfd_code ^= 0
	then call error (smfd_code, "Could not set xmail accept short format flag.");

	call message_facility_$set_alarm_handler (xim_msg_facility_mbx_ptr,
	     smfd_message_facility_data.alarm_entry, smfd_message_facility_data.alarm_info_ptr,
	     smfd_message_facility_data.alarm_time, smfd_code);
	if smfd_code ^= 0
	then call error (smfd_code, "Could not set xmail accept alarm handler information.");

	call message_facility_$set_wakeup_handler (xim_msg_facility_mbx_ptr,
	     smfd_message_facility_data.wakeup_entry, smfd_message_facility_data.wakeup_info_ptr, smfd_code);
	if smfd_code ^= 0
	then call error (smfd_code, "Could not set xmail accept wakeup handler information.");

	return;

     end set_message_facility_data;

print_unseen_messages: proc;

/* AUTOMATIC */

	dcl     pum_code		 fixed bin (35);
	dcl     pum_i		 fixed bin;
	dcl     pum_work_area_ptr      ptr;
	dcl     01 pum_msg_print_flags like msg_print_flags;
          dcl     cleanup                condition;

          dcl     get_temp_segment_      entry (char(*), ptr, fixed bin(35));
          dcl     xmail_area_$create     entry (ptr, fixed bin(35));

/* BEGIN */

	pum_work_area_ptr = null;
	on cleanup begin;
	     call CLEANUP;
	     end;

	call get_temp_segment_ (NAME, pum_work_area_ptr, pum_code);
	call xmail_area_$create (pum_work_area_ptr, pum_code); 
	if pum_code ^= 0 
	then do;
	     call print_error;
	     goto exit_print_unseen_messages;
	     end;
	call message_facility_$get_msg_array_ptr (xim_msg_facility_mbx_ptr,
	     pum_work_area_ptr, msg_array_ptr, n_messages, pum_code);
	if pum_code ^= 0
	then do;
	     call print_error;
	     goto exit_print_unseen_messages;
	end;

	pum_msg_print_flags.print_prefix = "1"b;
	pum_msg_print_flags.print_ename = "0"b;
	pum_msg_print_flags.print_sender = "1"b;
	pum_msg_print_flags.print_date_and_time = "1"b;
	pum_msg_print_flags.print_time = "0"b;
	pum_msg_print_flags.print_last_message = "0"b;
	pum_msg_print_flags.mbz = "0"b;

	do pum_i = 1 to n_messages;
	     if ^msg_array (pum_i).printed
	     then do;
		call message_facility_$print_message (xim_msg_facility_mbx_ptr, iox_$user_io,
		     msg_array (pum_i).message_id, addr (pum_msg_print_flags), pum_code);
		if pum_code ^= 0
		then do;
		     call print_error;
		     goto exit_print_unseen_messages;
		end;
		call message_facility_$set_seen_switch (xim_msg_facility_mbx_ptr,
		     msg_array (pum_i).message_id, DELETE_UNHELD, pum_code);
		if pum_code ^= 0
		then do;
		     call print_error;
		     goto exit_print_unseen_messages;
		end;
	     end;
	end;
          
          call CLEANUP;

exit_print_unseen_messages:
	return;

     end print_unseen_messages;

print_error: proc;

	call ioa_ ("An error has occured while trying to print newly arrived messages." ||
	     "^/You may print these messages after exiting Executive Mail with^/the ""print_messages -new"" command.");
	call timer_manager_$sleep (4, "11"b);

	return;

     end print_error;

error: proc (e_code, e_message);

/* PARAMETERS */

	dcl     e_code		 fixed bin (35);
	dcl     e_message		 char (*);

/* ENTRIES */

          dcl     xmail_error_$code_first entry () options (variable);

/* BEGIN */

	call xmail_error_$code_first (e_code, NAME, QUIT, e_message);

     end error;

CLEANUP:  proc;

          dcl code                  fixed bin (35);
          dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35));

	if pum_work_area_ptr ^= null
          then call release_temp_segment_ (NAME, pum_work_area_ptr, code);

    end CLEANUP;

    end xmail_im_mgr;




		    xmail_list_msgs_.pl1            05/28/86  1058.5rew 05/28/86  1024.1       78903



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




/****^  HISTORY COMMENTS:
  1) change(86-02-26,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Added new entrypoint xmail_list_msgs_$set_seen_switch which uses a
     structure of messages built by xmail_select_msgs_ and turns the seen
     switch on or off depending on the value in switch_on_off.  This entrypoint
     is called from xmail_Consult_Files_ or xmail_Process_Mail_ after the
     messages have been selected.
                                                   END HISTORY COMMENTS */


xmail_list_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_iocb_ptr);

/* Author unknown.

   83-07-13  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.
*/

/* Parameter */

	dcl     (P_mailbox_ptr, P_curr_msgsp, P_iocb_ptr) ptr;

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     i			 fixed bin;
	dcl     info_width		 fixed bin;
	dcl     iocb_ptr		 ptr;
	dcl     message_num		 fixed bin;

/* Static */

	dcl     MARK_CURRENT_MSGS	 bit (1) int static options (constant) init ("1"b);
	dcl     ME_CHAR		 char (16) int static options (constant) init ("xmail_list_msgs_");
	dcl     MIN_INFO_WIDTH	 fixed bin int static options (constant) init (67);

	dcl     (xmail_err_$mailbox_empty,
	        xmail_err_$all_msgs_deleted,
	        xmail_err_$no_curr_msgs) fixed bin (35) ext;

/* Entries */

	dcl     get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     mlsys_utils_$print_message_summary entry (ptr, fixed bin, bit (1) aligned, fixed bin, ptr, fixed bin (35));
	dcl     mlsys_utils_$print_message_summary_header entry (fixed bin, ptr, fixed bin (35));
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));

/* builtin */

	dcl     (addr, null)	 builtin;

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error.");

	if P_curr_msgsp = null
	then ;
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	end;

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgsp;
	iocb_ptr = P_iocb_ptr;

	if mailbox.n_messages = 0
	then call xmail_error_$code_first (xmail_err_$mailbox_empty, ME_CHAR, "i");

	if mailbox.n_messages <= mailbox.n_deleted_messages
	then call xmail_error_$code_first (xmail_err_$all_msgs_deleted, ME_CHAR, "i");

	call calc_info_width (info_width, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to get width of screen. This is an internal programming error.");

	call mlsys_utils_$print_message_summary_header (info_width, iocb_ptr, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to print message summary header. This is an internal programming error.");

	do i = 1 to mailbox.n_messages;
	     message_num = i;
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		call mail_system_$read_message (mailbox_ptr, message_num, code);
		if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
	     end;
	     message_ptr = mailbox.messages (message_num).message_ptr;

	     if ^message.marked_for_deletion
	     then do;
		call mlsys_utils_$print_message_summary (message_ptr, message_num, a_curr_msg (message_num), info_width, iocb_ptr, code);
		if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to get summary for message ^d. This is an internal programming error.", message_num);
	     end;
	end;
EXIT:

	return;

selected: entry (P_mailbox_ptr, P_curr_msgsp, P_iocb_ptr);

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error.");

	if P_curr_msgsp = null
	then call xmail_error_$code_first (xmail_err_$no_curr_msgs, ME_CHAR, "i");
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	end;

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgsp;
	iocb_ptr = P_iocb_ptr;

	call calc_info_width (info_width, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to get width of screen. This is an internal programming error.");

	call mlsys_utils_$print_message_summary_header (info_width, iocb_ptr, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to print message summary header. This is an internal programming error.");

	do i = 1 to curr_msgs.count;
	     message_num = curr_msgs.numbers (i);
	     message_ptr = mailbox.messages (message_num).message_ptr;

	     call mlsys_utils_$print_message_summary (message_ptr, message_num, ^MARK_CURRENT_MSGS, info_width, iocb_ptr, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to get summary for message ^d. This is an internal programming error.");
	end;

	return;

set_seen_switch: entry (P_mailbox_ptr, P_curr_msgsp, P_switch);
	       
          dcl     P_switch               bit (1) aligned;
          dcl     mail_system_$set_message_switch entry (ptr, char (4) aligned, bit (1) aligned, fixed bin (35));

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error.");
	
	if P_curr_msgsp = null
          then call xmail_error_$code_first (xmail_err_$no_curr_msgs, ME_CHAR, "i");
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	     end;

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgsp;

	do i = 1 to curr_msgs.count;
	     message_num = curr_msgs.numbers (i);
	     message_ptr = mailbox.messages (message_num).message_ptr;
	     call mail_system_$set_message_switch (message_ptr, PER_MESSAGE_SEEN_SWITCH_TYPE, P_switch, code);
	     if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to set the SEEN switch. This is an internal programming error.");
	     end;
	return;

%page;
/* Internal procedures */

a_curr_msg: proc (P_msg_num) returns (bit (1) aligned);

	dcl     P_msg_num		 fixed bin;
	dcl     i			 fixed bin;

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

	do i = 1 to curr_msgs.count;
	     if curr_msgs.numbers (i) = P_msg_num
	     then return ("1"b);
	end;

	return ("0"b);

     end a_curr_msg;

calc_info_width: proc (P_width, P_code);

	dcl     P_width		 fixed bin;
	dcl     P_code		 fixed bin (35);
	dcl     window_width	 fixed bin;
	dcl     error_table_$no_operation fixed bin (35) ext static;

	dcl     1 auto_window_position_info like window_position_info;

	P_code = 0;

	auto_window_position_info.version = window_position_info_version;
	call iox_$control (iocb_ptr, "get_window_info", addr (auto_window_position_info), P_code);
	if P_code = 0 then window_width = auto_window_position_info.width;
	else if P_code = error_table_$no_operation	/* output going to a file, possibly */
	then do;
	     window_width = get_line_length_$switch (iocb_ptr, (0));
	     P_code = 0;
	end;

/* We need to show a certain minimum amount of information. */

	if MIN_INFO_WIDTH > window_width
	then P_width = MIN_INFO_WIDTH;
	else P_width = window_width;

     end calc_info_width;

%page;
%include mlsys_mailbox;
%page;
%include rdm_switch_types;
%page;
%include mlsys_message;
%page;
%include xmail_curr_msg_info;
%page;
%include window_control_info;

     end xmail_list_msgs_;




		    xmail_multics_mode_.pl1         09/02/88  0759.6r w 09/02/88  0748.3       66960



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



/****^  HISTORY COMMENTS:
  1) change(86-01-13,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-17 JG Backs: Replaced all the Message Facility commands
     (accept_messages, defer_messages, print_messages) with calls to the new
     xmail_im_mgr_ module which uses the new Message Facility entrypoints for
     these functions.
  2) change(86-01-13,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Add cleanup handler to set flag which will allow messages marked for
     deletion to be unmarked.
  3) change(86-07-18,Blair), approve(86-07-18,MCR7447),
     audit(86-07-18,LJAdams), install(86-07-21,MR12.0-1100):
     Add a call to xmail_im_mgr_$init before returning back to xmail so we can
     detect when the user has changed his processing options for interactive
     msgs while in multics mode.
                                                   END HISTORY COMMENTS */


xmail_multics_mode_: proc;

/* BEGIN DESCRIPTION

function:
			xmail_multics_mode_

	This program is called to invoke multics mode in the bottom
	window during the execution of xmail.  It tells the user
	what is happenning (in case he doesn't know) and how to get
	back to the menu.  Then it calls the command processor.
	Upon return, it clears the window and returns to its caller.

history:
   Written 7/17/81 by Paul Kyzivat

   Modified 7/21/81 by Paul Kyzivat to only print help once per process

   83-07-07 DJ Schimke: Removed unreferenced dcl of quit condition.
   Added code to selectively disable the interactive message handling. This
   option should eventually be available from the personalize menu as
   suggested by phx12801.

   83-09-20 DJ Schimke: Add call to xmail_window_manager_$reconnect to clear 
   window_status_pending on any windows after returning to xmail. phx 14080

   84-05-30 DJ Schimke: Changed the multics mode interface to use the whole
   screen (original user_io) when necessary by forming overlapping windows.
   There are two advantages to this approach: users have more room for multics 
   commands and the previous contents of the bottom window are preserved for
   the user (in case there is a useful pathname etc.).

   84-09-24 JG Backs: Added "-brief" control argument to print_messages 
   command so the message "You have no messages" would not print. This is to
   make xmail compatible with the new message facility for mr11.

   84-11-13 JG Backs: Initialized code to 0 at the beginning of the module.
   Without initialization, an error was being logged if it was not the
   first time multics mode was called in a process.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     code		 fixed bin (35);
	dcl     delta		 fixed bin;
	dcl     mm_status_msg	 char (80) var;
	dcl     restoration_required	 bit (1) aligned;
	dcl     rs_length		 fixed bin;
	dcl     saved_bwi_height	 fixed bin;
	dcl     saved_bwi_line	 fixed bin;
	dcl     1 bottom_window_info	 like window_position_info;

/* BUILTINS */

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

/* CONDITIONS */

	dcl     any_other		 condition;
          dcl     cleanup                condition;
	dcl     program_interrupt	 condition;

/* CONSTANTS */

	dcl     NAME		 char (19) int static init ("xmail_multics_mode_") options (constant);
	dcl     MM_STATUS_MSG	 char (39) int static init ("Type ""pi"" to return to Executive Mail") options (constant);

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr ext static;

/* INTERNAL STATIC */

	dcl     first_time		 bit (1) int static init ("1"b); /* indicates if first invocation */

/* ENTRIES */

	dcl     continue_to_signal_	 entry (fixed bin (35));
	dcl     cu_$cl		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     xmail_display_help_	 entry (char (*), char (*), fixed bin (35));
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_redisplay_$menu	 entry;
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_im_mgr_$defer_messages entry ();
	dcl     xmail_im_mgr_$init entry ();
	dcl     xmail_im_mgr_$print_messages entry ();
	dcl     xmail_im_mgr_$restore_original entry ();

/* INCLUDE FILES */

%include xmail_data;
%page;
%include xmail_help_infos;
%page;
%include xmail_windows;
%page;
%include window_dcls;
%page;
%include window_status;

/* BEGIN */

	code = 0;					/* initialize code */

	if first_time then call xmail_display_help_ (MULTICS_MODE_HELP, "", code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot get help for multics mode. This is an internal programming error.");
	if xmail_data.interactive_msgs then do;
		call xmail_im_mgr_$print_messages;
		call xmail_im_mgr_$restore_original;
	     end;

	restoration_required = "0"b;
	on cleanup begin;
	     call CLEANUP;
	     end;
	on program_interrupt begin;
		call restore_menu;
		if xmail_data.interactive_msgs
		then do;
		     call xmail_im_mgr_$init ();
		     call xmail_im_mgr_$defer_messages ();
		     end;
		call continue_to_signal_ ((0));
	     end;
	call window_$clear_window (xmail_windows.mm_status.iocb, code);
	call ioa_$rsnnl ("^vt^a", mm_status_msg, rs_length, divide ((xmail_windows.mm_status.position.width - length (MM_STATUS_MSG)), 2, 17, 0) + 2, MM_STATUS_MSG);
	call window_$overwrite_text (xmail_windows.mm_status.iocb, substr (mm_status_msg, 1, rs_length), code);
	call xmail_redisplay_$menu ();
	first_time = "0"b;
	call suppress_menu;
	on any_other system;
	call cu_$cl;
	call xmail_window_manager_$reconnect ();
	call window_$clear_window (iox_$user_output, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, "l", "Cannot clear user_io window. This is an internal programming error.");
	if xmail_data.interactive_msgs
	then call xmail_im_mgr_$defer_messages ();
	call xmail_redisplay_$menu ();

suppress_menu: proc;
	bottom_window_info = xmail_windows.bottom.position;
	saved_bwi_height = bottom_window_info.height;
	saved_bwi_line = bottom_window_info.origin.line;
	delta = xmail_windows.menu.height + xmail_windows.status.height - 1;
	bottom_window_info.height = bottom_window_info.height + delta;
	bottom_window_info.origin.line = bottom_window_info.origin.line - delta;

	call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), code);
	restoration_required = "1"b;
	return;
     end suppress_menu;

restore_menu: proc;
	if restoration_required then do;
		bottom_window_info.height = saved_bwi_height;
		bottom_window_info.origin.line = saved_bwi_line;
		call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), (0));
	     end;
	return;
     end restore_menu;

CLEANUP: proc;
         xmail_data.cleanup_signalled = "1"b;
         end;
  

    end xmail_multics_mode_;




		    xmail_prepare_msg_.pl1          09/02/88  0759.6r w 09/02/88  0748.1      122409



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



/****^  HISTORY COMMENTS:
  1) change(86-01-17,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Set off the flag that indicates that the message no longer exists in the
     on units rather than as part of normal cleanup.  This will ensure that a
     message is still available for filing even after the user has answered no
     to creating a new file when none exists. TR 20028.
  2) change(87-08-10,Blair), approve(87-12-10,MCR7818),
     audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013):
     Add reply-to handling for new messages.
                                                   END HISTORY COMMENTS */


xmail_prepare_msg_: procedure (P_store);

/* BEGIN DESCRIPTION

function:

   This procedure is used to process an existing message or a new one.
   In cases where a new message is being created, this procedure calls
   a modified version of Emacs to collect the user's message, i.e., the
   "subject", the "recipients" list, the "cc" list, the "bcc" list, and
   finally the "message text". In cases of an existing message it allows
   one to modify and/or enter new text, recipient list, or subject.
   The message is then passed to mail_system_. The mail_system creates
   standard message. It is then sent to the recipients. It may then be
   filed, edited, etc.. The extensions to Emacs that are used to do
   this are in segment xmail_emacs_ext_main_.

history:

   81-06-11 Written by R. Ignagni 

   83-10-20 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a 
   call to xmail_window_manager_$quit_handler so the quit condition handler
   can special-case the reconnect condition which should NOT interrupt 
   processing after the quit. phx 13227 This entry also prompts when not at
   a reconnect condition so that unintentionally hitting the BREAK won't 
   throw away any pending work. phx 13018

   83-11-01 DJ Schimke: Changed the calling sequence of xmail_select_file_.

   84-08-08 JG Backs: Modified for the addition of blind carbon copies (bcc).

   84-09-24 JG Backs: Added code before and after the call to emacs_ to test
   if menus should be removed before editing (personalization option Remove
   Menus While Editing).  If option is in effect, calls to new entrypoints,
   $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also
   added test in quit handler to make sure restore menus is done if quit in
   editor.

   84-11-07 JG Backs: Modified the name of the input parameter from P_caller
   to P_store for clarity.  Changed the call and declaration statement of
   xmail_process_user_msg_ to eliminate the parameter which was not needed
   or used, and was eliminated from that module.  Audit change.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     P_store		 bit (1) parameter; /* input;  "1"b = prepare & store msg; 
						                    "0"b = prepare & send msg */

/* CONDITIONS */

	dcl     (quit, cleanup)	 condition;

/* CONSTANTS */

	dcl     ALLOW_NEW		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     ALLOW_OLD		 bit (1) aligned int static options (constant) init ("1"b);
	dcl     DELETE_SEG_FORCE_CHASE bit (6) int static options (constant) init ("100101"b);
	dcl     EMACS_EXT		 char (21) options (constant) init ("xmail_emacs_ext_main_") int static;
	dcl     ENTRY_NAME		 entry variable init (xmail_prepare_msg_);
	dcl     ERROR_MESSAGE	 char (67) static options (constant) init ("Sending of message not completed, due to an internal program error.");
	dcl     HIT_QUIT_KEY	 char (19) static options (constant) init ("Sending terminated.");
	dcl     NAME		 char (18) static options (constant) init ("xmail_prepare_msg_");
	dcl     STOP		 char (1) static options (constant) init ("q");
	dcl     TERM_FILE_BC	 bit (2) int static options (constant) init ("01"b);

/* EXTERNAL STATIC */

	dcl     error_table_$namedup	 fixed bin (35) ext;
	dcl     error_table_$segknown	 fixed bin (35) ext;
	dcl     iox_$user_output	 ptr external static;

/* INTERNAL STATIC */

	dcl     ext_dir		 char (168) int static;
	dcl     ext_file		 char (32) int static;
	dcl     ext_ptr		 ptr init (null) int static;
	dcl     ext_pname		 char (168) int static;

/* AUTOMATIC */

	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     emacs_flavor	 char (32);
	dcl     no_chars		 fixed bin (24);
	dcl     restore_menu_needed	 bit (1) aligned;	/* if remove menu */
	dcl     status		 fixed bin (35);
	dcl     store_dir		 char (168);
	dcl     store_file		 char (32) var;
	dcl     stored_msg_ptr	 ptr;
	dcl     suffix		 char (4);
	dcl     temp_seg_ptr	 ptr;
	dcl     type		 fixed bin (2);
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;
	dcl     user_msg_seg_entry_name char (32);

/* ENTRIES */

	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35));
	dcl     emacs_		 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     get_pdir_		 entry () returns (char (168));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry options (variable);
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     mail_system_$free_address_list entry (ptr, fixed bin (35));
	dcl     mail_system_$free_message entry (ptr, fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     xmail_error_$no_code	 entry options (variable);
	dcl     xmail_process_user_msg_ entry ();	/* no parameter */
	dcl     xmail_redisplay_$menu	 entry ();
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     xmail_sw_$update_usage entry (char (*));
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_window_manager_$suppress_menu entry ();
	dcl     xmail_window_manager_$restore_menu entry ();

/* BUILTINS */

	dcl     (addr, codeptr, divide, null, rtrim) builtin;

/* BASED */

	dcl     based_string	 char (no_chars) based (temp_seg_ptr);

/* INCLUDE FILES */

%include access_mode_values;
%page;
%include xmail_data;
%page;
%include xmail_send_mail;
%page;
%include window_dcls;

/* BEGIN */

	restore_menu_needed = "0"b;
	send_mail_info.stored_seg_ptr = null ();
	temp_seg_ptr = null ();
	stored_msg_ptr = null ();


/*  Update status window */

	call xmail_sw_$update_usage (" ");
	call xmail_sw_$redisplay ();
	call ioa_$nnl (" ");

/*  Free any current address list(s), msg ptr, and create seg for Emacs to 
    place new message in   */

	if P_store
	then suffix = "_ssm";

	else do;
	     suffix = "_sm ";
	     if send_mail_info.new_msg_ptr ^= null ()
	     then do;
		call mail_system_$free_message (send_mail_info.new_msg_ptr, code);
		if code ^= 0 then send_mail_info.new_msg_ptr = null ();
	     end;
	     if send_mail_info.to_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.to_list_ptr,
		     code);
		if code ^= 0 then send_mail_info.to_list_ptr = null ();
	     end;
	     if send_mail_info.cc_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.cc_list_ptr, code);
		if code ^= 0 then send_mail_info.cc_list_ptr = null ();
	     end;

/* Add reply-to handling */
	     if send_mail_info.reply_to_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.reply_to_list_ptr, code);
		if code ^= 0 then send_mail_info.reply_to_list_ptr = null ();
	     end;

/* Add bcc handling */

	     if send_mail_info.bcc_list_ptr ^= null ()
	     then do;
		call mail_system_$free_address_list (send_mail_info.bcc_list_ptr, code);
		if code ^= 0 then send_mail_info.bcc_list_ptr = null ();
	     end;


/* Initialize the status of the message */

	     send_mail_info.msg_exists = "0"b;
	end;

/* Set up quit and clean up conditions */

	on condition (cleanup) begin;
	     send_mail_info.msg_exists = "0"b;
	     call CLEAN_UP;
	     end;
	on condition (quit)
	     begin;
	          send_mail_info.msg_exists = "0"b;
		if xmail_window_manager_$quit_handler ()
		then do;
		     if restore_menu_needed






		     then do;
			call xmail_window_manager_$restore_menu;
			call xmail_redisplay_$menu;
		     end;
		     call window_$clear_window (iox_$user_output, (0)); /* ignore code */
		     call ioa_ (HIT_QUIT_KEY);
		     call CLEAN_UP;
		     go to EXIT;
		end;
	     end;

/* Create seg (or trim existing seg) to be used by emacs for the user msg */

	user_msg_seg_entry_name = xmail_data.actee.person || suffix;
	call hcs_$make_seg ("", user_msg_seg_entry_name, "", RW_ACCESS_BIN, temp_seg_ptr, code);
	if code = error_table_$namedup | code = error_table_$segknown
	then do;
	     bit_count = 0;
	     call terminate_file_ (temp_seg_ptr, bit_count, TERM_FILE_BC, code);
	end;
	if code ^= 0
	then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);

	send_mail_info.emacs_seg_pathname = get_pdir_ ();
	if P_store
	then send_mail_info.stored_seg_ptr = temp_seg_ptr;
	else send_mail_info.emacs_seg_ptr = temp_seg_ptr;
	send_mail_info.emacs_seg_pathname = rtrim (send_mail_info.emacs_seg_pathname) || ">" || user_msg_seg_entry_name;

/* Call emacs_ for preparing message. */

	if ext_ptr = null ()
	then do;
	     call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "",
		ext_ptr, code);
	     if code ^= 0 then call xmail_error_$no_code
		     (code, NAME, STOP, "^a", ERROR_MESSAGE);
	     call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0),
		ext_file, code);
	     if code ^= 0 then call xmail_error_$no_code
		     (code, NAME, STOP, "^a", ERROR_MESSAGE);
	     ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT;
	end;


	emacs_flavor = "send";
	bit_count = 0;
	call ioa_ ("... Please wait for editor ...");

/* Check personalization option to remove and restore menus while editing */

	if xmail_data.remove_menus
	then do;
	     call xmail_window_manager_$suppress_menu ();
	     restore_menu_needed = "1"b;
	end;

	call emacs_ (iox_$user_output, (send_mail_info.emacs_seg_pathname),
	     ext_pname, addr (emacs_flavor), status);

	if restore_menu_needed
	then do;
	     call xmail_window_manager_$restore_menu ();
	     call xmail_redisplay_$menu;
	     restore_menu_needed = "0"b;
	end;

	call hcs_$status_mins (temp_seg_ptr, type, bit_count, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);
	if bit_count = 0
	then do;
	     call xmail_window_manager_$reconnect ();
	     call ioa_ (HIT_QUIT_KEY);
	     call CLEAN_UP;
	     goto EXIT;
	end;

	if status = 1
	then do;
	     call store_msg ();
	     goto EXIT;
	end;

/* If forwarding message now then call proc for extracting the "subject", 
"text", and determining the primary and secondary (if any) recipients
 address list structures */


	call xmail_process_user_msg_ ();		/* no parameter */
EXIT:
	return;

/* INTERNAL PROCEDURES */

store_msg: proc ();


/* ENTRIES */

	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));

/* BASED */

	dcl     stored_string	 char (no_chars) based (stored_msg_ptr);

/* BEGIN */


	call xmail_select_file_$caller_msg ("deferred message", "defer", "", ALLOW_OLD, ALLOW_NEW, store_dir, store_file, "Type name you wish to give the ""deferred message"" (or ?? for list)", unused_bit, unused_bit2, code);
	if code ^= 0
	then do;
	     call ioa_ ("Sorry, ""deferred message"" not saved.");
	     call CLEAN_UP;
	     return;
	end;

	stored_msg_ptr = null ();
	call hcs_$make_seg (store_dir, rtrim (store_file) || ".defer", "", RW_ACCESS_BIN, stored_msg_ptr, code);

	if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segknown then do;
	     call ioa_ ("Sorry, unable to save ""deferred message"". This is an internal error.");
	     call CLEAN_UP;
	     return;
	end;

	call terminate_file_ (stored_msg_ptr, bit_count, TERM_FILE_BC, code);

/* Get number of chars in seg */

	no_chars = divide (bit_count, 9, 17, 0);

	stored_string = based_string;
	call ioa_ ("Deferred message  ""^a"" saved.", store_file);

	return;
     end store_msg;

CLEAN_UP: proc ();

	if temp_seg_ptr ^= null ()
	then call delete_$ptr (temp_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, code);
	send_mail_info.stored_seg_ptr = null ();
/*	send_mail_info.msg_exists = "0"b;      
 * the above line was moved to the on unit so that the message will only *
 * be marked as non_existant on a true cleanup condition, but will other-*
 * wise still be available.                                              */
	send_mail_info.emacs_seg_pathname = "";
	return;
     end CLEAN_UP;

     end xmail_prepare_msg_;




		    xmail_print_.pl1                10/28/88  1416.3r w 10/28/88  1302.1      237519



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



/****^  HISTORY COMMENTS:
  1) change(86-02-27,Blair), approve(86-02-27,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-22 Joanne Backs: Modified to add 3 new entrypoints to $get_ and
     $set_: copies, left_margin, and notify.  Added the conversion and size
     conditions and the CONVERT internal procedure to support these new
     printing options which can be set in the Personalize Exec Mail menu.
     
     85-04-01 Joanne Backs: Added a short CONFIRM_FIRST internal procedure to
     display a prompt for changing the printing options before actually doing
     printing, but if the answer to the prompt is yes, just inform the user the
     option is not implemented yet.
     
     85-04-02 Joanne Backs: Added calls to ioa_ to display a message to the user
     if the dprint was sucessfully submitted.  A short message will be seen if
     the confirm option is set and the printing options have already been
     displayed, but the longer message at all other times.  These messages were
     extracted from xmail_dprint_msgs_ and xmail_dprint_mlist_ to be consistant.
     
     85-04-25 Joanne Backs: Added new internal procedures TEMP_CHANGE and
     PERFORM_CHANGE to allow the user to temporarily change any of the print
     options via a lower window dynamic menu.  PERFORM_CHANGE will call the
     respective entrypoint in xmail_Review_Defaults_ to get the new value
     but will not permanently change the value in the value segment.
     
     85-04-26 JG Backs: Modified CONFIRM_FIRST to output one prompt the first
     time the printing options are listed and output a different prompt after
     changes are made.
  2) change(87-05-10,Gilcrease), approve(87-05-14,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Update to version 9 dprint_arg.
                                                   END HISTORY COMMENTS */


xmail_print_: proc;
	return;

/* BEGIN DESCRIPTION 

function:
			xmail_print_

	The xmail_print_ subroutine is a utility for requesting hard
	copy output in the xmail environment.  It has entrypoints for
	creating a segment to contain the output until it is printed,
	submitting the segment to be printed, and for deleting a segment
	if the need to print it goes away before it is printed.  Entries
	are also provided for manipulation of the stored attributes used
	to route output.

	Once a segment is submitted for printing it becomes the
	responsibility of xmail_print_.  It determines the method of
	output delivery most suitable for the current user, delivers the
	output, and deletes the segment when delivery is known to have
	been accomplished.  Future versions will actually interogate the
	user as to the delivery status of requested output and re-issue
	requests for lost output.  The initial version will deliver
	output via dprint_ and depend upon the daemon to delete segments
	when they have been printed.

history: 
   Written  7/8/81 by Paul Kyzivat 

   81-07-20 Paul Kyzivat: Add the get/set entries.

   82-10-11 Dave Schimke: Modified to use dp_args version 7.

   84-09-27 Joanne Backs: Modified to use dp_args version 8.
   
END DESCRIPTION
*/

/* PARAMETERS */

	dcl     id		 char (*) parameter,
	        dir		 char (*) parameter,
	        ent		 char (*) parameter,
	        description		 char (*) parameter,
	        value		 char (*) parameter,
	        seg_ptr		 ptr parameter,
	        dprint_arg_ptr	 ptr parameter,
	        code		 fixed bin (35);

/* AUTOMATIC */

	dcl     bc		 fixed bin (24),
	        local_ent		 char (32),
	        local_dir		 char (168),
	        name_len		 fixed bin,
	        suffix		 char (32),
	        type		 fixed bin (2),
	        yes_sw                 bit (1) aligned;

/* CONSTANTS */

	dcl     CHASE		 init (1) fixed bin (1) static options (constant);
	dcl     1 CREATED_FILE_FORMAT	 static options (constant),
		2 PREFIX		 char (3) init ("dp."),
		2 UNIQUE		 char (15) init ("!??????????????"),
		2 SUFFIX		 char (3) init (".**");
	dcl     DELETE_SEG		 init ("000100"b) bit (6) static options (constant);
	dcl     NAME                   init ("xmail_print_") char (12) static options (constant);
	dcl     NO		 char (2) init ("no") static options (constant);
	dcl     RW_MODE		 fixed bin (5) init (01010b) static options (constant);
	dcl     RW_MODE_INIT_FILE	 bit (3) init ("101"b) static options (constant);
	dcl     YES		 char (3) init ("yes") static options (constant);

/* EXTERNAL STATIC */

	dcl     error_table_$oldnamerr fixed bin (35) ext static,
	        error_table_$bad_conversion fixed bin (35) ext static,
	        error_table_$smallarg	 fixed bin (35) ext static;

/* ENTRIES */

	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35)),
	        delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35)),
	        hcs_$append_branch	 entry (char (*), char (*), fixed bin (5), fixed bin (35)),
	        hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
	        hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
	        hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
	        hcs_$terminate_noname	 entry (ptr, fixed bin (35)),
	        ioa_                   entry() options(variable),
	        initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)),
	        unique_chars_	 entry (bit (*)) returns (char (15)),
	        xmail_get_str_$yes_no  entry (char (*) var, bit (1) aligned);

/* CONDITIONS */

	dcl     cleanup		 condition;

/* BUILTINS */

	dcl     (convert, length, min, null, rtrim, substr) builtin;

/* INCLUDE FILES */

%include dprint_arg;
%page;
%include window_dcls;
%page;
%include xmail_data;

/* ENTRYPOINTS */

/*
			xmail_print_$create_file

	This entry creates a file to be used for generation of hardcopy
	output.  The directory is chosen automatically, and the
	entryname is generated uniquely but containing a caller
	specified identification.  The directory and entrynames are
	returned to the caller.  It is the responsibility of the caller
	to either request printing of the file or request its deletion.

     id
	is a brief (16 characters or less) identification of file
	contents.  It will become part of the file name.

     dir
	(OUTPUT) is the directory containing the file.

     ent
	(OUTPUT) is the entryname of the created file.

     code
	(OUTPUT) is a system status code.
*/

create_file: entry (id, dir, ent, code);

	if id ^= "" then suffix =
		"." || substr (id, 1, min (length (id), 16));
	else suffix = "";

	ent = CREATED_FILE_FORMAT.PREFIX || unique_chars_ (""b) || suffix;
	dir = xmail_data.mail_dir;

	call hcs_$append_branch (dir, ent, RW_MODE, code);
	return;

/*
			xmail_print_$create_seg

	This entry creates a segment to be used for generation of
	hardcopy output.  The directory is chosen automatically, and the
	entryname is generated uniquely but containing a caller
	specified identification.  The segment is initiated with a null
	reference name and a pointer returned to the caller.  It is the
	responsibility of the caller to either request printing of the
	segment or request its deletion.

     id
	is a brief (16 characters or less) identification of
	segment contents.  It will become part of the file name.

     seg_ptr
	(OUTPUT) is a pointer to the created segment.

     code
	See above.
*/

create_seg: entry (id, seg_ptr, code);

	seg_ptr = null;
	local_dir, local_ent = "";

	on condition (cleanup) call delete_file (local_dir, local_ent, (0));

	call create_file (id, local_dir, local_ent, code);
	if code = 0 then call initiate_file_ (local_dir, local_ent, RW_MODE_INIT_FILE, seg_ptr, bc, code);
	return;

/*
			xmail_print_$submit_file

	This entry point requests that a file (identified by pathname)
	be printed.  The file need not have been created by
	xmail_print_$create_file.  Options controlling the printing are
	specified via a dprint_arg structure identical to that used in
	calling dprint_.  A text description of the file or its contents
	is required, for use in conversing with the user about the file.
	This will be necessary in order to determine whether a file has
	been received by the user.

     dir
	(INPUT) is the directory containing the file to be printed.

     ent
	(INPUT) is the entryname of the file to be printed.

     description
	(INPUT) is a short (one line) description of the contents of the
	file, for purposes of communication with the user about it.

     dprint_arg_ptr
	(INPUT)
	is a pointer to a standard dprint arg structure.  The following
	fields are ignored because they are determined internally: queue,
	pt_pch, heading, output_module, bit_count, destination, request_type,
	copies, lmargin, and notify.  In addition, delete is assumed if
          the file being printed was created by xmail_print_$create_file or
          xmail_print_$create_seg.  A null pointer may be passed, in which
          case defaults are used for all fields.

     code
	See above.
*/

submit_file: entry (dir, ent, description, dprint_arg_ptr, code);

	call hcs_$status_minf (dir, ent, CHASE, type, bc, code);
	if code = 0 then call SUBMIT
		(dir, ent, bc, description, dprint_arg_ptr, code);
	return;

/*
			xmail_print_$submit_seg

	This entry point requests that a segment (identified by pointer)
	be printed.  The segment need not have been created by
	xmail_print_$create_seg.  Options controlling the printing are
	specified via a dprint_arg structure identical to that used in
	calling dprint_.  A text description of the segment or its
	contents is required, for use in conversing with the user about
	the segment.  This will be necessary in order to determine
	whether a segment has been received by the user.  The segment
	will be terminated and seg_ptr set to null if and only if a zero
	is returned in code.

     seg_ptr
	is a pointer to the file to be printed.

     description
	See above.

     dprint_arg_ptr
	See above.

     code
	See above.
*/

submit_seg: entry (seg_ptr, description, dprint_arg_ptr, code);

	call hcs_$fs_get_path_name (seg_ptr, local_dir, name_len, local_ent, code);
	if code = 0 then call hcs_$status_mins (seg_ptr, type, bc, code);
	if code = 0 then call SUBMIT
		(local_dir, local_ent, bc, description, dprint_arg_ptr, code);
	if code = 0 then do;
		call hcs_$terminate_noname (seg_ptr, (0)); /* ignore error code */
		seg_ptr = null;
	     end;
	return;

/*
			xmail_print_$delete_file

	This entry point is used to delete a file created by
	xmail_print_$create_file when it is determined that the file is
	not needed and will not be printed.  This entry would normally
	be called from the cleanup condition handler of the procedure
	which requests the file.	

     dir
	is the directory containing the file to be deleted, as
	returned by xmail_print_$create_file.

     ent
	is the entry name of the file to be deleted, as returned by
	xmail_print_$create_file.

     code
	See above.
*/

delete_file: entry (dir, ent, code);

	call delete_$path (dir, ent, DELETE_SEG, "", code);
	return;

/*
			xmail_print_$delete_seg

	This entry point is used to delete a segment created by
	xmail_print_$create_seg when it is determined that the segment
	is not needed and will not be printed.  This entry would
	normally be called from the cleanup condition handler of the
	procedure which requests the segment.

     seg_ptr
	is a pointer to the segment to be deleted, as returned by
	xmail_print_$create_seg.

     code
	See above.
*/

delete_seg: entry (seg_ptr, code);

	call delete_$ptr (seg_ptr, DELETE_SEG, "", code);
	if code = 0 then seg_ptr = null;
	return;

/*
		xmail_print_$get_{heading destination request_type
		                  copies left_margin notify}

	These entries return the identified piece of information.
	They look for it in the value segment, and if not found they
	supply a default (if appropriate.)
*/

	dcl     (
	        DP_HEAD_VAR		 init ("dprint_heading"),
	        DP_DEST_VAR		 init ("dprint_destination"),
	        DP_RQT_VAR		 init ("dprint_request_type"),
	        DP_COPIES_VAR	 init ("dprint_copies"),
	        DP_LMARGIN_VAR	 init ("dprint_left_margin"),
	        DP_NOTIFY_VAR	 init ("dprint_notify")
	        )			 char (20) static options (constant);

get_heading: entry (value, code);

	call GET (DP_HEAD_VAR);
	if code = error_table_$oldnamerr
	then do;
	     if length (value) >= length (xmail_data.actee.person)
	     then do;
		value = xmail_data.actee.person;
		code = 0;
	     end;
	     else do;
	          value = "";
	          code = error_table_$smallarg;
	     end;
	end;
	return;

get_destination: entry (value, code);

	call GET (DP_DEST_VAR);
	if code = error_table_$oldnamerr
	then do;
	     value = "";
	     code = 0;
	end;
	return;

get_request_type: entry (value, code);

	call GET (DP_RQT_VAR);
	if code = error_table_$oldnamerr
	then do;
	     value = "";
	     code = 0;
	end;
	return;

get_copies: entry (value, code);

	call GET (DP_COPIES_VAR);

	if code = error_table_$oldnamerr
	then do;
	     value = "1";                                 /* default = 1 */
	     code = 0;
	end;
	return;

get_left_margin: entry (value, code);

	call GET (DP_LMARGIN_VAR);

	if code = error_table_$oldnamerr
	then do;
	     value = "0";                                 /* default = 0 */
	     code = 0;
	end;
	return;

get_notify: entry (value, code);

	call GET (DP_NOTIFY_VAR);

	if code = error_table_$oldnamerr
	then do;
	     value = NO;                                  /* default = no */
	     code = 0;
	end;

	return;

/*
		xmail_print_$set_{heading destination request_type
		                  copies left_margin notify}

	These entries redefine the identified piece of information in the
	value seg.
*/

set_heading: entry (value, code);

	call SET (DP_HEAD_VAR);
	return;

set_destination: entry (value, code);

	call SET (DP_DEST_VAR);
	return;

set_request_type: entry (value, code);

	call SET (DP_RQT_VAR);
	return;

set_copies: entry (value, code);

	call SET (DP_COPIES_VAR);
	return;

set_left_margin: entry (value, code);

	call SET (DP_LMARGIN_VAR);
	return;

set_notify: entry (value, code);

	call SET (DP_NOTIFY_VAR);
	return;

SUBMIT: proc (print_dir, print_file, bitcount, desc, dp_args_param, status);

/* PARAMETERS */

	dcl     print_dir		 char (*),
	        print_file		 char (*),
	        bitcount		 fixed bin (24),
	        desc		 char (*),
	        dp_args_param	 ptr,
	        status		 fixed bin (35);

/* AUTOMATIC */

	dcl     user_heading	 char (64),
	        user_destination	 char (24),
	        user_request_type	 char (24),
	        user_copies 	 char (2),
	        user_copies_bin 	 fixed bin,
	        user_lmargin	 char (2),
	        user_lmargin_bin 	 fixed bin,
	        user_notify 	 char (3),
	        user_notify_bin 	 fixed bin,
	        matched		 fixed bin (35),
	        dp_args_p		 ptr,
	        1 dp_args		 aligned like dprint_arg based (dp_args_p),
	        1 default_dp_args	 aligned like dprint_arg;

/* CONSTANTS */

          dcl     COPIES_LIMIT           fixed bin static options (constant) init (30);
          dcl     LEFT_MARGIN_LIMIT      fixed bin static options (constant) init (20);

/* EXTERNAL STATIC */

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

/* ENTRIES */

	dcl     match_star_name_	 entry (char (*), char (*), fixed bin (35)),
	        dprint_		 entry (char (*), char (*), ptr, fixed bin (35));

/* BUILTINS */

	dcl     (addr, null, string, unspec) builtin;

/* BEGIN */

	call get_heading (user_heading, status);
	if status = 0 then call get_destination (user_destination, status);
	if status = 0 then call get_request_type (user_request_type, status);
	if status = 0 then call get_copies (user_copies, status);
	if status = 0 then call get_left_margin (user_lmargin, status);
	if status = 0 then call get_notify (user_notify, status);

	if status ^= 0 then return;

/*  Convert and check values of copies, lmargin, and notify  */

          call CONVERT (user_copies, user_copies_bin, status);
	if status ^= 0 then return;
          if user_copies_bin > COPIES_LIMIT
          then do;
     	     user_copies = "1";                           /* use default */
	     user_copies_bin = 1;
	end;

          call CONVERT (user_lmargin, user_lmargin_bin, status);
	if status ^= 0 then return;
          if user_lmargin_bin > LEFT_MARGIN_LIMIT
          then do;
     	     user_lmargin = "0";                          /* use default */
	     user_lmargin_bin = 0;
	end;

	if user_notify = YES
	     then user_notify_bin = 1;
	     else user_notify_bin = 0;                    /* use default */

	if dp_args_param = null then do;
		dp_args_p = addr (default_dp_args);
		unspec (dp_args) = ""b;
		dp_args.version = dprint_arg_version_9;
		dp_args.delete = 0;
		string (dp_args.carriage_control) = ""b;
		dp_args.line_lth = -1;
		dp_args.page_lth = -1;
		dp_args.top_label = "";
		dp_args.bottom_label = "";
		dp_args.form_name = "";
		dp_args.chan_stop_path = "";
	     end;
	else do;
		dp_args_p = dp_args_param;
		if dp_args.version ^= dprint_arg_version_9 then do;
			status = error_table_$unimplemented_version;
			return;
		     end;
	     end;

	if xmail_data.confirm_print
	then call CONFIRM_FIRST;

	dp_args.queue = 0;				/* default */
	dp_args.pt_pch = 1;				/* print */
	dp_args.output_module = 1;			/* print */
	dp_args.bit_count = bitcount;
	dp_args.heading = user_heading;
	dp_args.destination = user_destination;
	dp_args.request_type = user_request_type;
	dp_args.defer_until_process_termination = 0;
	dp_args.copies = user_copies_bin;
	dp_args.lmargin = user_lmargin_bin;
	dp_args.notify = user_notify_bin;

	call match_star_name_ (print_file, string (CREATED_FILE_FORMAT), matched);
	if matched = 0 then dp_args.delete = 1;

	call dprint_ (print_dir, print_file, dp_args_p, status);

	if xmail_data.confirm_print
	then call ioa_ ("Print request has been submitted.");
	else do;
	     if user_request_type = "" then user_request_type = "system default printer";
	     if user_destination = "" then user_destination = "not specified";
	     call ioa_ ("Request for printed copy has been submitted to printer: ^a^/Printed copy to be delivered to: ""^a"".   Location: ""^a""", user_request_type, user_heading, user_destination);
	end;
     
SUBMIT_EXIT:
	return;

CONFIRM_FIRST: proc;                                        /* within SUBMIT */

/* AUTOMATIC */

	dcl     cf_first_time          bit (1) aligned;   /*first time flag*/

/* BEGIN */

	cf_first_time = "1"b;

	do while ("1"b);
	     call ioa_ ("  Header:        ^a", user_heading);
	     call ioa_ ("  Destination:   ^[not specified^;^a^]", user_destination = "", user_destination);
	     call ioa_ ("  Station:       ^[system default printer^;^a^]", user_request_type= "", user_request_type);
	     call ioa_ ("  Left Margin:   ^a", user_lmargin);
	     call ioa_ ("  Copies:        ^a", user_copies);
	     call ioa_ ("  Notify:        ^a^/", user_notify);
	     if cf_first_time
	     then do;
		call xmail_get_str_$yes_no ("Do you wish to temporarily change any options before printing?", yes_sw);
		cf_first_time = "0"b;
	     end;
	     else call xmail_get_str_$yes_no ("Do you wish to make any more changes?", yes_sw);
	     if ^yes_sw then go to CONFIRM_EXIT;
	     call TEMP_CHANGE;
	end;

CONFIRM_EXIT:
	return;

     end CONFIRM_FIRST;

TEMP_CHANGE: proc ();

/*
     Produces a dynamic menu in the lower window providing options to
     temporarily change the printing options from the personalization
     menu
*/

/* CONSTANTS */

	dcl     TEMP_CHANGE_CHOICES	 dim (6) char (26) int static options (constant)init
                                        ("Set Header",
				 "Set Destination",
				 "Set Station",
				 "Set Left Margin",
				 "Set Number of Copies",
				 "Notify After Printing") aligned var;

/* AUTOMATIC */

	dcl     tc_choice		 fixed bin;
	dcl     tc_code		 fixed bin (35);
	dcl     tc_selected_done       bit (1) aligned;
	dcl     temp_change_menup	 ptr init (null) int static;

/* ENTRIES */

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     xmail_dyn_menu_$create_w_trailer entry ((*) char (*) aligned, char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_dyn_choice_$trailer entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_sw_$update_usage entry (char (*));
	dcl     xmail_sw_$redisplay	 entry ();

/* EXTERNAL STATIC */

	dcl     iox_$user_output       ptr ext static;

/* BEGIN */

	if temp_change_menup = null
	then do;
	     call xmail_dyn_menu_$create_w_trailer ((TEMP_CHANGE_CHOICES), "<List changes>", temp_change_menup, null, get_system_free_area_ (), tc_code);
	     if tc_code ^= 0
	     then call xmail_error_$no_code (tc_code, NAME, "q", "Unable to create temporary print change menu.^/  This is an internal programming error.");
	end;

	do while ("1"b);
	     call xmail_sw_$update_usage ("");
	     call xmail_sw_$redisplay ();
	     call window_$clear_window (iox_$user_output, (0));
	     call xmail_get_dyn_choice_$trailer (temp_change_menup, tc_choice, tc_selected_done, tc_code);

	     if tc_selected_done then go to TEMP_CHANGE_EXIT;
	     if tc_code ^= 0
	     then call xmail_error_$no_code (tc_code, NAME, "q", "Unable to display temporary print change menu.^/  This is an internal programming error.");
	     call window_$clear_window (iox_$user_output, (0));
	     call PERFORM_CHANGE (tc_choice);

	     call xmail_get_str_$yes_no ("More changes?", yes_sw);
	     if ^yes_sw then go to TEMP_CHANGE_EXIT;
	end;

TEMP_CHANGE_EXIT:
          call window_$clear_window (iox_$user_output, (0));
	return;


PERFORM_CHANGE: proc (opt);

/* PARAMETERS */

	dcl     opt		 fixed bin parameter;/* input */

/* AUTOMATIC */

	 dcl    name                   char (26) varying;
           dcl    new_value              char (200) varying;
           dcl    new_value_bin          fixed bin;

/* ENTRIES */

	dcl     xmail_Review_Defaults_$get_new_copies entry (char (*), char (*) var, fixed bin);
	dcl     xmail_Review_Defaults_$get_new_destination entry (char (*), char (*) var);
	dcl     xmail_Review_Defaults_$get_new_header entry (char (*), char (*) var);
	dcl     xmail_Review_Defaults_$get_new_margin entry (char (*), char (*) var, fixed bin);
	dcl     xmail_Review_Defaults_$get_new_notify entry (char (*), char (*), char(*) var);
	dcl     xmail_Review_Defaults_$get_new_station entry (char (*), char (*) var);

/* BEGIN PERFORM_CHANGE */

	name = TEMP_CHANGE_CHOICES (opt);                  /* include name of option*/
	go to OPT (opt);

OPT (1):	
	call xmail_Review_Defaults_$get_new_header (user_heading, new_value);
	if length (new_value) ^= 0
	then user_heading = new_value;
	go to OPT_EXIT;

OPT (2):	
	call xmail_Review_Defaults_$get_new_destination (user_destination, new_value);
	if length (new_value) ^= 0
	then user_destination = new_value;
	go to OPT_EXIT;

OPT (3):	
	call xmail_Review_Defaults_$get_new_station (user_request_type, new_value);
	if new_value = "default"
	then user_request_type = "";                    /* null for default*/
	else if length (new_value) ^= 0
	     then user_request_type = new_value;
	go to OPT_EXIT;

OPT (4):	
	call xmail_Review_Defaults_$get_new_margin (user_lmargin, new_value, new_value_bin);
	if length (new_value) ^= 0
	then do;
	     user_lmargin = new_value;                    /* for message */
	     user_lmargin_bin = new_value_bin;            /* for dprint_ */
	end;
	go to OPT_EXIT;

OPT (5):	
	call xmail_Review_Defaults_$get_new_copies (user_copies, new_value, new_value_bin);
	if length (new_value) ^= 0
	then do;
	     user_copies = new_value;                     /* for message */
	     user_copies_bin = new_value_bin;             /* for dprint_ */
	end;
	go to OPT_EXIT;

OPT (6):	
	call xmail_Review_Defaults_$get_new_notify ((name), user_notify, new_value);
	if length (new_value) ^= 0
	then do;
	     user_notify = new_value;                     /* for message */
	     if new_value = YES
	     then user_notify_bin = 1;                    /* for dprint_ */
	     else user_notify_bin = 0;
	end;
	go to OPT_EXIT;

OPT_EXIT: return;
     end PERFORM_CHANGE;

     end TEMP_CHANGE;

     end SUBMIT;

CONVERT: proc (c_value_char, c_value_bin, c_status);

/*
     Converts a character value to a binary value so it can be tested
     against limits and inserted in the dprint_ structure.
*/

/* PARAMETERS */

          dcl     c_value_char          char (*);           /* input */
          dcl     c_value_bin           fixed bin;          /* output */
          dcl     c_status              fixed bin (35);     /* output */

/* CONDITIONS */

          dcl     (conversion, size) condition;

/* BEGIN */

          c_status = 0;

          on conversion, size 
	     c_status = error_table_$bad_conversion;

          c_value_bin = convert (c_value_bin, c_value_char);

	revert conversion, size;
	return;

     end CONVERT;

GET: proc (name);

	dcl     name		 char (20);
	dcl     result		 char (64) varying;
	dcl     xmail_value_$get	 entry (char (*), char (*) var, fixed bin (35)),
	        xmail_value_$set	 entry (char (*), char (*) var, char (*) var, fixed bin (35));

	call xmail_value_$get (name, result, code);
	if code = 0 then do;
		if length (value) >= length (result)
		then value = result;
		else do;
			value = "";
			code = error_table_$smallarg;
		     end;
	     end;
	return;

SET: entry (name);

	call xmail_value_$set (name, rtrim (value), result, code);
	return;

     end GET;
	      
    end xmail_print_;




		    xmail_process_user_msg_.pl1     09/02/88  0759.6r w 09/02/88  0747.6      131553



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



/****^  HISTORY COMMENTS:
  1) change(86-06-25,Blair), approve(86-07-15,MCR7447),
     audit(86-07-18,LJAdams), install(86-07-21,MR12.0-1100):
     Accept the old format of "Cc:" so that users can read their deferred
     messages which were created before the format changed to "cc:" for copies.
     Error #119.
  2) change(86-06-25,Blair), approve(86-07-15,MCR7447),
     audit(86-07-18,LJAdams), install(86-07-21,MR12.0-1100):
     When passing arguments to the mail_system routines which build the
     message, precede the keywords used to delimit the contents of the header
     fields with a NL to make sure that keywords which are part of the text are
     not used incorrectly. TR 20269.
  3) change(87-08-10,Blair), approve(87-12-10,MCR7818),
     audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013):
     Add capability to parse a Reply-To field in a message header and process
     the supplied value.
                                                   END HISTORY COMMENTS */


xmail_process_user_msg_: procedure ();


/* BEGIN DESCRIPTION

function:

   This proc is called by xmail_prepare_msg_ to extract the "subject
   text and the "message" text from the msg prepared by the user via
   emacs.  It uses the mlsys_utils_$parse_address_list_text proc to
   establish the primary and secondary (if any) recipients address
   structure lists.  Note that this procedure assumes that there are no
   syntax errors in the user specified list of addresses and/or address
   lists since the emacs extention does this as well as determining 
   that for every address specified there is a corresponding mailbox.

history:

   81-07-03  Written by R. Ignagni, format: style1.

   83-07-13  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   84-08-07  JG Backs: Modified for the addition of blind carbon copies (bcc)

   84-11-08  JG Backs: Removed the input parameter P_caller, which was not
   used anywhere in module, but was passed to xmail_send_msg_.  Since it also
   was not used there, it was removed in both places, changing the call and
   declaration statement of module xmail_send_msg_ to eliminate the parameter.
   These changes also required respective changes to xmail_prepare_msg_ and
   xmail_send_stored_msg_, which are the only two modules calling this module.
   Audit change.

   84-11-09  JG Backs: Deleted the spaces within the quotes of "To:", "cc:",
   and "bcc:" because they were not needed and were inconsistant within and
   across modules.  Audit change.

END DESCRIPTION
*/

/* CONDITIONS */

	dcl     (quit, cleanup)	 condition;

/* STATIC */

	dcl     wrong_format	 char (31) static options (constant) init ("Message not in expected format.");
	dcl     error_message	 char (67) static options (constant)
				 init ("Sending of message not completed, due to an internal program error.");
	dcl     WHITE_SPACE		 char (4) aligned static options (constant) init ("
 	");					/* HT VT NL <space> */
	dcl     WHITE_SPACE_COMMA	 char (6) aligned static options (constant) init ("
	  ,");					/* HT VT NL <space> comma */
	dcl     NAME		 char (23) static options (constant) init ("xmail_process_user_msg_");
          dcl     NL                     char (1) int static options (constant) init ("
");
	dcl     stop		 char (1) static options (constant) init ("q");

/* AUTOMATIC */

	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
          dcl     copy_format            char (3);
          dcl     follows_copy           char (8);
          dcl     new_style              bit (1) aligned;
	dcl     no_chars		 fixed bin (21);
          dcl     old_style              bit (1) aligned;
	dcl     start_of_text	 fixed bin;

	dcl     1 auto_message_body_section_parameter automatic like message_body_section_parameter;

	dcl     1 auto_parse_text_options automatic like parse_text_options;

/* BASED */

	dcl     based_string	 char (no_chars)
				 based (send_mail_info.emacs_seg_ptr);
	dcl     based_array		 (no_chars) char (1)
				 based (send_mail_info.emacs_seg_ptr);

/* ENTRIES */

	dcl     xmail_send_msg_	 entry ();	/* no parameter */
	dcl     xmail_error_$no_code	 entry options (variable);
	dcl     xmail_error_$code_last entry options (variable);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     mail_system_$add_body_section
				 entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$create_message
				 entry (char (8), ptr, fixed bin (35));
	dcl     mail_system_$free_address_list
				 entry (ptr, fixed bin (35));
	dcl     mail_system_$free_message
				 entry (ptr, fixed bin (35));
	dcl     mail_system_$replace_bcc
				 entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$replace_cc
				 entry (ptr, ptr, fixed bin (35));
          dcl     mail_system_$replace_reply_to
    		                     entry (ptr, ptr, fixed bin (35));      dcl     mail_system_$replace_subject
				 entry (ptr, char (*), fixed bin (35));
	dcl     mail_system_$replace_to
				 entry (ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$parse_address_list_text
				 entry (char (*), ptr, char (8), ptr, ptr, fixed bin (35));
	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));

/* BUILTIN */

	dcl     (addr, after, before, divide, index, length, ltrim, null, rtrim, substr) builtin;

/* INCLUDE FILES */

%include mlsys_message;
%page;
%include xmail_data;
%page;
%include window_dcls;
%page;
%include xmail_send_mail;
%page;
%include mlsys_address_list;
%page;
%include mlsys_parse_txt_options;

/* BEGIN */

/* Set up quit and cleanup conditions */

START:	parse_text_error_list_ptr, message_ptr = null ();

	on condition (cleanup) call CLEAN_UP;
	on condition (quit)
	     begin;
		call xmail_window_manager_$reconnect ();
		call ioa_ ("Sending message terminated.");
		call CLEAN_UP;
		go to exit;
	     end;


	call hcs_$status_mins (send_mail_info.emacs_seg_ptr, 1, bit_count, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message);

/* Get number of chars in seg */

	if bit_count = 0				/* The user "quit" while in emacs */
	then do;
	     call ioa_ ("Sending message terminated.");
	     call CLEAN_UP;
	     return;
	end;
	no_chars = divide (bit_count, 9, 17, 0);

/* Extract the "Subject", "To", "cc", and "bcc" fields from the segment created
   by Emacs   */

	old_style, new_style = "0"b;
	if index (based_string, "Cc:") > 0 then do;
	     old_style = "1"b;
	     copy_format = "Cc:";
	     follows_copy = "Message:";
	     end;
	if index (based_string, "cc:") > 0 then do;
	     new_style = "1"b;
	     copy_format = "cc:";
	     follows_copy = "bcc:";
	     end;

	
	if (^(old_style | new_style) |
	     (index (based_string, "Subject:") = 0) |
	     (index (based_string, "To:") = 0) |
/*	     (index (based_string, "cc:") = 0) |
	     (index (based_string, "bcc:") = 0) |        replaced by old_style new_style */
	     (index (based_string, "Message:") = 0))
	then call xmail_error_$no_code (code, NAME, stop, "^a Sending terminated.", wrong_format);
	if new_style & (index (based_string, "bcc:") = 0) 
	     then call xmail_error_$no_code (code, NAME, stop, "^a Sending terminated.", wrong_format);
	
	if rtrim (after (based_string, "Message:"), WHITE_SPACE) = ""
	then call xmail_error_$no_code (code, NAME, "i", "No message text entered. Sending terminated.");

	call mail_system_$create_message (MESSAGE_VERSION_2, send_mail_info.new_msg_ptr, code);

	if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message);

/* Supply "subject" for the new message */

	call mail_system_$replace_subject (send_mail_info.new_msg_ptr, (after (before (based_string, NL || "Reply-To:"), "Subject:"))|| NL, code);

	if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message);

/* Supply the "message" field for the new message */

	message_body_section_ptr = addr (auto_message_body_section_parameter.section);
	auto_message_body_section_parameter.version =
	     MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;
	message_preformatted_body_section.header.section_type =
	     MESSAGE_PREFORMATTED_BODY_SECTION;
	message_preformatted_body_section.header.section_n_lines = -1;
	start_of_text = index (based_string, NL || "Message:") + length ("Message:") + 1;
	message_preformatted_body_section.text_ptr =
	     addr (based_array (start_of_text));
	message_preformatted_body_section.text_lth =
	     length (substr (rtrim (based_string), start_of_text));

	call mail_system_$add_body_section (send_mail_info.new_msg_ptr, addr (auto_message_body_section_parameter), 1, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message);

/* Convert text to address lists for To:, bcc:, and cc: fields  */

	send_mail_info.to_list_ptr,
               send_mail_info.reply_to_list_ptr,
	     send_mail_info.cc_list_ptr,
	     send_mail_info.bcc_list_ptr = null ();

	auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1;
	auto_parse_text_options.area_ptr = null;
	auto_parse_text_options.flags.list_errors = "0"b;
	auto_parse_text_options.flags.validate_addresses = "0"b;
	auto_parse_text_options.flags.include_invalid_addresses = "0"b;
	auto_parse_text_options.flags.mbz = "0"b;

	if rtrim (after (before (based_string, NL || "To:"), NL || "Reply-To:"), WHITE_SPACE_COMMA) || NL = ""
	     then goto PROCESS_TO;
	else do;
	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "To:"), NL ||
		"Reply-To:") || NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2,
		send_mail_info.reply_to_list_ptr, parse_text_error_list_ptr, code);
	     if code ^= 0 then call xmail_error_$code_last ( code, NAME, stop, "^a^/", error_message);
	     call mail_system_$replace_reply_to (send_mail_info.new_msg_ptr, send_mail_info.reply_to_list_ptr, code);
	     if code ^= 0 then call xmail_error_$code_last ( code, NAME, stop, "^a^/", error_message);
	     end;

PROCESS_TO:	     
	if rtrim (after (before (based_string, NL || copy_format), NL || "To:"), WHITE_SPACE_COMMA) || NL = ""
	then call xmail_error_$no_code (code, NAME, "i", "You did not enter any recipients. Sending terminated.");

	call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || copy_format),NL || "To:") || NL, WHITE_SPACE_COMMA),
	     addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.to_list_ptr, parse_text_error_list_ptr, code);
	if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message);
	call mail_system_$replace_to (send_mail_info.new_msg_ptr, send_mail_info.to_list_ptr, code);
	if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message);

	if ltrim (rtrim (after (before (based_string,NL || rtrim(follows_copy)), NL ||copy_format), WHITE_SPACE_COMMA), WHITE_SPACE_COMMA) || NL ^= ""
	then call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || rtrim(follows_copy)), NL || copy_format)|| NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.cc_list_ptr, parse_text_error_list_ptr, code);
	if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message);
	if send_mail_info.cc_list_ptr ^= null
	then do;
	     call mail_system_$replace_cc (send_mail_info.new_msg_ptr, send_mail_info.cc_list_ptr, code);
	     if code ^= 0
	     then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message);
	end;

/* Add bcc handling */
          if new_style then 
	if ltrim (rtrim (after (before (based_string,  NL || "Message:"), NL || "bcc:"), WHITE_SPACE_COMMA), WHITE_SPACE_COMMA) || NL ^= ""
	then call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string,  NL || "Message:"), NL || "bcc:") || NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.bcc_list_ptr, parse_text_error_list_ptr, code);
	if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message);
	if send_mail_info.bcc_list_ptr ^= null
	then do;
	     call mail_system_$replace_bcc (send_mail_info.new_msg_ptr, send_mail_info.bcc_list_ptr, code);
	     if code ^= 0
	     then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message);
	end;

	send_mail_info.msg_exists = "1"b;

	if parse_text_error_list_ptr ^= null ()
	then do;
	     free parse_text_error_list;
	     parse_text_error_list_ptr = null ();
	end;
	call xmail_send_msg_ ();			/* no parameter */
	return;

exit:	return;

%page;
/* INTERNAL PROCEDURES */

CLEAN_UP: proc ();

	if send_mail_info.emacs_seg_ptr ^= null () then
	     call delete_$ptr (send_mail_info.emacs_seg_ptr, "100101"b, NAME, code);
	if send_mail_info.new_msg_ptr ^= null () then
	     call mail_system_$free_message (send_mail_info.new_msg_ptr, code);
	if code ^= 0 then send_mail_info.to_list_ptr = null ();
	if send_mail_info.to_list_ptr ^= null () then
	     call mail_system_$free_address_list (send_mail_info.to_list_ptr, code);
	if code ^= 0 then send_mail_info.reply_to_list_ptr = null ();
	if send_mail_info.reply_to_list_ptr ^= null () then
	     call mail_system_$free_address_list (send_mail_info.reply_to_list_ptr, code);
	if code ^= 0 then send_mail_info.cc_list_ptr = null ();
	if send_mail_info.cc_list_ptr ^= null () then
	     call mail_system_$free_address_list (send_mail_info.cc_list_ptr, code);
	if code ^= 0 then send_mail_info.bcc_list_ptr = null ();
	if send_mail_info.bcc_list_ptr ^= null () then
	     call mail_system_$free_address_list (send_mail_info.bcc_list_ptr, code);
	send_mail_info.emacs_seg_ptr = null ();
	send_mail_info.new_msg_ptr = null ();
	send_mail_info.msg_exists = "0"b;
	send_mail_info.emacs_seg_pathname = "";
	return;

     end CLEAN_UP;


     end xmail_process_user_msg_;





		    xmail_rebuild_value_seg_.pl1    09/02/88  0759.6rew 09/02/88  0736.1      106587



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


/****^  HISTORY COMMENTS:
  1) change(86-02-11,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Written by J. Blair.
  2) change(87-04-17,Blair), approve(87-04-22,MCR7683),
     audit(87-05-15,RBarstad), install(87-05-26,MR12.1-1037):
     Enable the cp_escape for when we have to query the user for continuing
     when we rebuild the value_seg.  TR 20776.
  3) change(88-06-28,Blair), approve(88-07-27,MCR7959),
     audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098):
     Add new entry point (copy) for when we have read access to the mlsys value
     seg, but can't write to it.
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This program allows the xmail value segment to be rebuilt when one of the value names	*/
/* contains invalid data or the segment appears to be damaged in some way.  This routine	*/
/* is called from xmail_value_.                                                           */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


xmail_rebuild_value_seg_: proc (xrvs_value_ptr, xrvs_code);

/* BEGIN */


	on cleanup begin;
		call CLEANUP;
	     end;

/* Get rid of the bad value segment */

	xrvs_value_seg_ptr = xrvs_value_ptr;
	call terminate_file_ (xrvs_value_seg_ptr, bc, TERM_FILE_DELETE, code);
	if code = 0 & xrvs_value_seg_ptr ^= null then do;
		user_name = xmail_data.person;
		call user_info_$homedir (homedir);
		mlsys_dir_entry = user_name || MLSYS_DIR_SUFFIX;
		value_dir = rtrim (homedir) || ">" || mlsys_dir_entry;
		seg_type = 0;			/* permanent value seg */
		call ioa_ ("^/     The value segment which contains your personalization options");
		call ioa_ ("     contains invalid data or cannot be accessed for some reason.");
		call ioa_ ("     A new value segment will be built in your mlsys directory.");
		call ioa_ ("     You may reset the personalization options by selecting");
		call ioa_ ("     ""Personalize Exec Mail"" from the main menu.^/");
		end;
	else do;
		value_dir = get_pdir_ ();
		seg_type = 1;			/* temporary value seg */
		call ioa_ ("^/     The value segment which contains your personalization options");
		call ioa_ ("     cannot be altered or deleted.  A temporary value segment with");
		call ioa_ ("     default personalization option values has been created for you");
		call ioa_ ("     in your process_dir.  These options may be changed, but the new");
		call ioa_ ("     values will only have effect for the duration of your process.^/");
	     end;

	call PRESS_TO_CONTINUE;
	xrvs_value_seg_ptr = null;
	call initiate_file_$create (value_dir, (VALUE_SEG_NAME), REW_ACCESS, xrvs_value_seg_ptr, created_sw, bc, code);
	call MAIN;
	return;

copy:	entry (P_value_seg_ptr, P_code);
%include copy_options;
%include copy_flags;

dcl       P_value_seg_ptr ptr;
dcl       P_code fixed bin (35) parm;
dcl       01 my_copy_options like copy_options;
dcl       fs_util_$copy entry (ptr, fixed bin(35));

          value_dir = get_pdir_();
	xmail_data.value_seg_pathname = value_dir;
	call initiate_file_$create (value_dir, (VALUE_SEG_NAME), REW_ACCESS, xrvs_value_seg_ptr, created_sw, bc, code);
	if code = 0 then
	     if ^created_sw then call MAIN;
	     else do;
		my_copy_options.version = COPY_OPTIONS_VERSION_1;
		user_name = xmail_data.person;
		call user_info_$homedir (homedir);
		mlsys_dir_entry = user_name || MLSYS_DIR_SUFFIX;
		value_dir = rtrim (homedir) || ">" || mlsys_dir_entry;
		my_copy_options.source_dir = value_dir ;
		my_copy_options.source_name = VALUE_SEG_NAME;
		my_copy_options.target_dir = get_pdir_();
		my_copy_options.target_name = VALUE_SEG_NAME;
		my_copy_options.no_name_dup = "1"b;
		my_copy_options.raw = "0"b;
		my_copy_options.force = "0"b;
		my_copy_options.delete = "0"b;
		my_copy_options.flags.mbz = "0"b;
                    my_copy_options.copy_items = "0"b;
                    my_copy_options.copy_items.update = "1"b;
		call fs_util_$copy (addr(my_copy_options), code);
		if code = 0 then do;
		call ioa_ ("^/     The value segment which contains your personalization options");
		call ioa_ ("     cannot be altered or deleted.  A temporary value segment with");
		call ioa_ ("     copies of your personalization option values has been created for");
		call ioa_ ("     you in your process_dir.  These options may be changed, but the");
		call ioa_ ("     new values will only have effect for the duration of your process.^/");
		call PRESS_TO_CONTINUE;
		P_value_seg_ptr = xrvs_value_seg_ptr;
		end;
		end;
	P_code = code;
	return;

MAIN:	 proc ();
/* Create a new value_segment. Put it in the process_dir if there was some reason
   you couldn't get rid of the old one, otherwise it goes in the mlsys_dir.  */

	if code = 0 & created_sw
	then call value_$init_seg (xrvs_value_seg_ptr, seg_type, null, 0, code);
	if code ^= 0 then goto XMAIL_REBUILD_VALUE_SEG_EXIT;
	else xmail_data.value_seg_pathname = value_dir;
/* Set all the default values in the value segment if we have a new one*/

	if created_sw then do;

	          call SET_DEFAULT (xrvs_value_seg_ptr, VERSION, (xmail_version));
		call SET_DEFAULT (xrvs_value_seg_ptr, SAVE_MESSAGE, (YES));
		call SET_DEFAULT (xrvs_value_seg_ptr, SAVE_MAILBOX, (ASK));
		call SET_DEFAULT (xrvs_value_seg_ptr, "lifetime_first_invocation", (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, ACKNOWLEDGE, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, LISTS_AS_MENUS, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, INTERACTIVE_MSGS, (YES));
		call SET_DEFAULT (xrvs_value_seg_ptr, ALWAYS_ESCAPE, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, MULTICS_MODE, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, REMOVE_MENUS, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, CONFIRM_PRINT, (YES));
		call SET_DEFAULT (xrvs_value_seg_ptr, INCLUDE_ORIGINAL, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, FILE_ORIGINAL, (NO));
		call SET_DEFAULT (xrvs_value_seg_ptr, ORIGINAL_IN_WINDOW, (YES));
	     end;
	xrvs_code = 0;
	return;

XMAIL_REBUILD_VALUE_SEG_EXIT:
	call CLEANUP;
	xrvs_code = 1;
	return;

	
SET_DEFAULT: proc (sd_value_seg_ptr, sd_value_name, sd_default);

/* PARAMETERS */

	dcl     sd_value_name	 char (*);
	dcl     sd_default		 char (*);
          dcl     sd_value_seg_ptr       ptr;
          dcl     PERMANENT              init ("01"b) bit (36) aligned static options (constant);

/* BEGIN */

	call value_$set (sd_value_seg_ptr, PERMANENT, sd_value_name, (sd_default), answer_yn, code);
	if code ^= 0
	then goto XMAIL_REBUILD_VALUE_SEG_EXIT;

     end SET_DEFAULT;
     end MAIN;
PRESS_TO_CONTINUE: proc;
	         
          dcl prompt                     char (46) init ("                    Press <RETURN> to continue") int static options (constant);
	dcl 1 auto_query_info          like query_info;
          dcl been_thru_this_before      bit (1) aligned;
	dcl line                       char (80) var;
          dcl iox_$user_output           ptr ext static;
          dcl command_query_             entry() options(variable);
          dcl iox_$control               entry (ptr, char(*), ptr, fixed bin(35));
	dcl ENABLE_ESCAPE             bit (2) aligned init ("11"b) int static options (constant);         

	auto_query_info.version = query_info_version_6;
	auto_query_info.switches.yes_or_no_sw = "0"b;
	auto_query_info.switches.suppress_name_sw = "1"b;
	auto_query_info.switches.cp_escape_control = ENABLE_ESCAPE;
	auto_query_info.switches.suppress_spacing = "1"b;
	auto_query_info.switches.literal_sw = "0"b;
	auto_query_info.switches.prompt_after_explanation = "0"b;
	auto_query_info.switches.padding = "0"b;
	auto_query_info.status_code = 0;
	auto_query_info.query_code = 0;
	auto_query_info.question_iocbp = null ();	/* default: user_i/o */
	auto_query_info.answer_iocbp = null ();		/* default: user_input */
	auto_query_info.repeat_time = 0;		/* don't repeat */
	auto_query_info.explanation_ptr = null ();
	auto_query_info.explanation_len = 0;

	been_thru_this_before = "0"b;
	do while ("1"b);
	     call iox_$control (iox_$user_output, "reset_more", null, (0)); /* ignore code */

	     call command_query_ (addr (auto_query_info), line, "", "^[^/^]^a^2x", been_thru_this_before, prompt);
	     been_thru_this_before = "1"b;

	     if line = "" then goto EXIT_PRESS_TO_CONTINUE;
	     end;
		
EXIT_PRESS_TO_CONTINUE: return;
     end PRESS_TO_CONTINUE;

CLEANUP: proc ();
         if xrvs_value_seg_ptr ^= null 
         then do;
	    call terminate_file_ (xrvs_value_seg_ptr, bc, TERM_FILE_DELETE, code);
	    xrvs_value_seg_ptr = null;
	    end;
	return;
     end CLEANUP;

%include query_info;
%include terminate_file;
%include access_mode_values;

%include xmail_data;

/* PARAMETERS */
          
          dcl     xrvs_value_ptr         ptr;
          dcl     xrvs_code              fixed bin (35);

/* AUTOMATIC */

	dcl     answer_yn		 char (3) var;
	dcl     bc		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     created_sw		 bit (1) aligned;
	dcl     homedir		 char (168);
	dcl     mlsys_dir_entry	 char (32);
	dcl     seg_type		 fixed bin;
	dcl     user_name		 char (35) var;
	dcl     value_dir		 char (168);
	dcl     xrvs_value_seg_ptr	 ptr;


/* ENTRIES   */

	dcl     get_pdir_		 entry () returns (char (168));
	dcl     initiate_file_$create	 entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     user_info_$homedir	 entry (char (*));
	dcl     value_$init_seg	 entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
          dcl     value_$set entry() options(variable);
          
/* BUILTINS  */

	dcl     (addr, null, rtrim)	 builtin;

/* CONDITIONS */

	dcl     cleanup		 condition;

/* CONSTANTS */
	dcl     ASK		 char (3) init ("ask") int static options (constant);
	dcl     MLSYS_DIR_SUFFIX	 char (6) init (".mlsys") int static options (constant);
	dcl     NO		 char (2) init ("no") int static options (constant);
	dcl     VALUE_SEG_NAME	 init ("xmail_data.value") char (32) var int static options (constant);
	dcl     VERSION		 init ("version") char (7) int static options (constant);
	dcl     YES		 char (3) init ("yes") int static options (constant);
	dcl     (
	/*** names of personalization options ***/
	        ACKNOWLEDGE		 char (14) init ("acknowledge_yn"),
	        ALWAYS_ESCAPE	 char (21) init ("always_escape_keys_yn"),
	        CONFIRM_PRINT	 char (19) init ("confirm_print_yn"),
	        FILE_ORIGINAL	 char (16) init ("file_original_yn"),
	        INCLUDE_ORIGINAL	 char (19) init ("include_original_yn"),
	        ORIGINAL_IN_WINDOW	 char (21) init ("original_up_window_yn"),
	        INTERACTIVE_MSGS	 char (19) init ("interactive_msgs_yn"),
	        LISTS_AS_MENUS	 char (17) init ("lists_as_menus_yn"),
	        MULTICS_MODE	 char (15) init ("multics_mode_yn"),
/*	        OUTGOING_SV_BOX	 char (32) init ("outgoing.sv.mbx"),  historic entry only */
	        REMOVE_MENUS	 char (15) init ("remove_menus_yn"),
	        SAVE_MAILBOX	 char (15) init ("save_mailfile"),
	        SAVE_MESSAGE	 char (15) init ("save_message_yn")
	        )			 static options (constant);

     end xmail_rebuild_value_seg_;




		    xmail_redisplay_.pl1            12/02/84  1109.7rew 12/02/84  1015.0       19242



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


xmail_redisplay_: proc ();

/* Author unknown

   83-09-14 DJ Schimke: Changed the call to iox_$control clear_window
   on video_data_$user_terminal to a window_$clear_window call on 
   xmail_data.moved_user_io. This fixes TR 12524 which complains that xmail
   clears the entire screen rather than only the window it is using.

   84-06-22 DJ Schimke: Changed xmail to resize user_io rather than syning
   user_io to xmail_bottom_window. This allows user specified keybindings and
   more prompts to be supported from within xmail. The call to clear the 
   moved_user_io window was changed to individual calls to clear the status, 
   menu, and bottom xmail windows.
*/

/* Entries */

	dcl     xmail_sw_$redisplay	 entry ();
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));

/* Condition */

	dcl     xmail_redisplay_menu	 condition;

all: entry ();

	call window_$clear_window (xmail_windows.status.iocb, (0)); /* ignore code */
	call window_$clear_window (xmail_windows.menu.iocb, (0)); /* ignore code */
	call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */

	call xmail_sw_$redisplay ();
	signal xmail_redisplay_menu;
	call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */

	return;					/* all */

status_window: entry ();

	call xmail_sw_$redisplay ();

	return;					/* status_window */

menu: entry ();

	signal xmail_redisplay_menu;

	return;					/* menu */

bottom_wndw: entry ();

	call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */

	return;					/* bottom_wndw */

%page;
%include xmail_windows;

     end xmail_redisplay_;




		    xmail_reply_msg_.pl1            10/06/92  0031.0r w 10/06/92  0026.4      512838



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





/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-01 JG Backs: Deleted the constant ASK because it was added to the
     include file xmail_responses.incl.pl1 and resulted in a compiler warning.
     85-05-07 JG Backs: Add an internal procedure to handle the new personalize
     Include Original in Reply option.
  2) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Move code to indicate reply was completed to before the code that
     asks if the message should be saved.  Add code to file the original
     before filing the reply when indicated.  Allow for suppressing the
     display of the original message in the upper window when indicated.
  3) change(86-01-17,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Check the delete_def_reply flag in CLEAN_UP to make sure that deleted
     deferred replies get deleted on cleanup.  TR 18152.
  4) change(86-01-28,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Add handler for reissue_query condition so that any question can be
     reissued after the user has hit break in response and then indicated that
     he wishes to continue.  TRs 18711 18974.
  5) change(86-10-15,Blair), approve(86-10-15,MCR7564),
     audit(86-10-28,RBarstad), install(86-10-29,MR12.0-1201):
     Make replies which include the original message display the message
     envelope so that the "Sender:" field will be displayed.  Fixes error_list
     129.
  6) change(87-01-21,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Grow the reply_msg buffer as necessary since 5000 characters isn't
     isn't always big enough.  Error_list 136.
  7) change(87-02-13,Blair), approve(87-02-13,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Set the static variable reply_request in xmail_data so that we'll be able
     to know that a reply was being processed when a disconnect occured.  Error
     list #114.
  8) change(87-11-06,Blair), approve(87-12-10,MCR7818),
     audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013):
     Move heaven and earth to add the "Reply-To:" field to deferred msgs so
     that when we get to the emacs editor, the user can edit this field.
     Rearrange code to query in the correct sequence (ask if we are to use
     deferred before we decide whether or not to include the original.
     Also make sure we don't delete the deferred reply when we defer a
     reply that was originally deferred.
  9) change(92-09-10,Zimmerman), approve(92-09-10,MCR8256), audit(92-09-15,Vu),
     install(92-10-06,MR12.5-1022):
     Fix bug with "Reply-To:" field.
                                                   END HISTORY COMMENTS */


xmail_reply_msg_: procedure (P_mailbox_ptr, P_curr_msgs_ptr);

/* BEGIN DESCRIPTION

function:

   This proc is invoked as a consequence of the user selecting the Reply
   option on the Process Incoming Mail or Process Filed Mail nemus. The
   being-replied-to message is displayed on the upper portion of the screen.
   The proc calls emacs so that the reply text can be composed and also to 
   permit the user to modify the default recipient list. If the user has so
   specified the message will be saved in the "outgoing" mbx. The reply will
   be acknowledged if the user has so specified. 

history:

   81-07-11  Written by R. Ignagni, extensively updated in Nov 1981

   83-07-18  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-09-15  DJ Schimke: Increased the initial size of the based array from
   600 characters to 5000 characters. The array wasn't always big enough for
   very large to or cc fields. 5000 should be plenty. phx13809

   83-09-21  DJ Schimke: Modified to query the user before creating a new mail
   file to save a copy of the reply. This is only in effect when save-outgoing
   is set to "ask". phx13779

   83-10-12  DJ Schimke: Replaced the call to mail_system_$save_message and
   associated code with a call to xmail_file_msgs_$single_msg;

   83-10-26 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a 
   call to xmail_window_manager_$quit_handler so the quit condition handler
   can special-case the reconnect condition which should NOT interrupt 
   processing after the quit. phx 13227 This entry also prompts when not at
   a reconnect condition so that unintentionally hitting the BREAK won't throw 
   away any pending work. phx 13018

   83-11-22 DJ Schimke: Removed the test for cc string ^= "" before parsing and
   replacing the cc_list_ptr in the reply message. This test didn't allow the
   user to delete the cc list even when xmail claimed to have deleted it.

   83-11-23 DJ Schimke: Added support for the new personalization option
   "Outgoing Savefile" which allows selection of where to file save messages.
   This also solves the discrepancy between setting "Save Outgoing messages"
   to "yes" and never having set "Save Outgoing messages".

   83-12-07 DJ Schimke: Cleaned up the reporting of delivery results by calling
   mlsys_utils_$print_delivery_results_ and mlsys_utils_$print_address_field 
   for displaying the failure/success of sending. This module still needs 
   recovery code to allow the sender to correct the bad addresses and continue.
   Deleted unused variable transition_state.

   83-12-08 DJ Schimke: Added simple flag to prevent the call to 
   mlsys_util_$free_delivery_results until the call to send the msg has been 
   made. Otherwise, this cleanup will get errors referencing invalid pointers.

   83-02-20 DJ Schimke: Modified the cleanup code so recipients_info is only
   freed by the CLEANUP procedure instead of the MESSAGE_CLEAN_UP procedure.
   This fixes a problem referencing recipients_info when replying to more than 
   one message (curr_msgs.count > 1). 

   84-08-08 JG Backs: Modified for the addition of blind carbon copies (bcc).

   84-11-08 JG Backs: Deleted the spaces within the quotes of "To:", "cc:"
   and "bcc:" when used in the calls to mlsys_utils_$parse_address_list_text.
   The spaces were not needed and were inconsistant across modules.  Audit
   change.

   

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     P_mailbox_ptr	 ptr parameter;
	dcl     P_curr_msgs_ptr	 ptr parameter;


/* CONDITIONS */

	dcl     (quit, cleanup, reissue_query)	 condition;

/* EXTERNAL STATIC */

	dcl     error_table_$bad_segment ext static fixed bin (35);
	dcl     error_table_$namedup	 ext static fixed bin (35);
	dcl     error_table_$segknown	 ext static fixed bin (35);
          dcl     error_table_$smallarg  ext static fixed bin (35);
	dcl     iox_$user_output	 ptr external static;
	dcl     mlsys_et_$no_a_permission static ext fixed bin (35);

/* CONSTANTS */

	dcl     ALLOW_SELECTION	 bit (1) aligned static options (constant) init ("1"b);
	dcl     ACKNOWLEDGE		 char (14) static options (constant) init ("acknowledge_yn");
	dcl     CONTINUE		 char (1) static options (constant) init ("c");
	dcl     BITS_PER_CHAR	 fixed bin static options (constant) init (9);
	dcl     DEFAULT_WIDTH	 fixed bin static options (constant) init (72);
	dcl     DELETE_SEG_FORCE	 bit (6) static options (constant) init ("100100"b);
	dcl     DELETE_SEG_FORCE_CHASE bit (6) static options (constant) init ("100101"b);
	dcl     EMACS_EXT		 char (21) options (constant) init ("xmail_emacs_ext_main_") int static;
	dcl     ENTRY_NAME		 entry variable init (xmail_reply_msg_);
	dcl     ERROR_MESSAGE	 char (69) static options (constant) init ("Reply to message no. ^d terminated, due to an internal program error.");
	dcl     ERRORS_ONLY		 bit (1) aligned static options (constant) init ("1"b);
	dcl     FILE_ORIGINAL	 char (32) static options (constant) init ("file_original_yn");
	dcl     FORMAT_SEG_NAME	 char (32) static options (constant) init ("format_orig_seg");
	dcl     INCLUDE_ORIGINAL	 char (19) static options (constant) init ("include_original_yn");
	dcl     LOG		 char (1) static options (constant) init ("l");
	dcl     MAILFILE_SUFFIX	 char (6) static options (constant) init ("sv.mbx");
	dcl     NAME		 char (16) static options (constant) init ("xmail_reply_msg_");
	dcl     NL		 char (1) aligned static options (constant) init ("
");
	dcl     NO_SELECTION	 bit (1) aligned static options (constant) init ("0"b);
	dcl     NO_WIDTH_LIMIT	 fixed bin static options (constant) init (-1);
	dcl     ORIGINAL_IN_WINDOW	 char (21) static options (constant) init ("original_up_window_yn");
	dcl     ORIG_SEG_NAME	 char (32) static options (constant) init ("orig_reply_seg");
	dcl     PROBLEM		 char (60) static options (constant) init ("Replying terminated. An internal program error has occurred.");
	dcl     REPLY_SEG_NAME	 char (13) static options (constant) init ("reply_msg_seg");
	dcl     QUIT		 char (1) static options (constant) init ("q");
	dcl     SECONDS		 bit (2) static options (constant) init ("11"b);
	dcl     SAVE_MAILBOX	 char (15) static options (constant) init ("save_mailfile");
	dcl     SAVE_MESSAGE	 char (15) static options (constant) init ("save_message_yn");
	dcl     STOP		 char (1) static options (constant) init ("q");
	dcl     USE_SCREEN_WIDTH	 fixed bin aligned static options (constant) init (-1);
	dcl     VIEW_SEG_NAME	 char (32) static options (constant) init ("view_reply_seg");
	dcl     WHITE_SPACE_COMMA	 char (6) aligned static options (constant) init ("
	  ,");					/* HT VT NL <space> comma */

/* INTERNAL STATIC */

	dcl     ext_pname		 char (168) int static;
	dcl     ext_ptr		 ptr init (null) int static;
	dcl     ext_dir		 char (168) int static;
	dcl     ext_file		 char (32) int static;

/* AUTOMATIC */

	dcl     acknowledge		 char (3) varying;
	dcl     bcc_list_ptr	 ptr;
	dcl     bit_count		 fixed bin (24);
	dcl     bit_count_view	 fixed bin (24);
          dcl     buffer_size            fixed bin (21);
          dcl     buffer_used            fixed bin (21);
	dcl     cc_list_ptr		 ptr;
	dcl     code		 fixed bin (35);
	dcl     code1		 fixed bin (35);
	dcl     default_save_file	 char (32) var;
	dcl     deferred_reply_exists	 bit (1);
	dcl     deferred_seg_name	 char (32) var;
	dcl     defrepl_seg_ptr	 ptr;
	dcl     delete_def_reply	 bit (1);
	dcl     delivery_results_need_cleanup bit (1) aligned;
	dcl     emacs_seg_path_name	 char (168);
	dcl     file_original	 char (3) var;
	dcl     for_type		 char (32);
          dcl     format_reply_length    fixed bin;
          dcl     format_reply           char (33);
	dcl     format_seg_ptr	 ptr;		/* ptr to temp segment for indented formatted original message */
	dcl     idx		 fixed bin;
	dcl     idx2		 fixed bin;
	dcl     iocb_ptr		 ptr;
	dcl     include_original	 bit (1);		/* flag: "1"=yes*/
	dcl     message_num		 fixed bin;
	dcl     more_than_one	 bit (1);
	dcl     no_chars		 fixed bin (21);
	dcl     no_chars_format	 fixed bin (21);
	dcl     no_chars_orig	 fixed bin (21);
	dcl     no_chars_view	 fixed bin (21);
	dcl     no_used		 fixed bin (21);
          dcl     opt                    fixed bin;
	dcl     original_in_window	 bit (1);		/* flag: "1"=yes */
	dcl     orig_seg_ptr	 ptr;		/* ptr to temp segment for printable original message */
	dcl     prompt_string	 char (160) var;
	dcl     repl_message_ptr	 ptr;
	dcl     reply_header	 char (27);
	dcl     reply_msg_area_ptr	 ptr;
	dcl     reply_msg_ptr	 ptr;
	dcl     reply_seg_ptr	 ptr;
	dcl     reply_to_list_ptr      ptr;
	dcl     resp		 char (1) var;
	dcl     response		 char (3) varying;	/* yes no or ask */
	dcl     save_message	 char (3) var;
	dcl     saved_menu_size	 fixed bin;
	dcl     sci_ptr		 ptr;
	dcl     start_of_bcc	 fixed bin;
	dcl     start_of_cc		 fixed bin;
	dcl     start_of_orig	 fixed bin;	/* original message */
	dcl     start_of_text	 fixed bin;
	dcl     status		 fixed bin (35);
	dcl     to_list_ptr		 ptr;
	dcl     type		 fixed bin (2);
          dcl     user_name              char (22);
	dcl     view_seg_ptr	 ptr;
	dcl     yes_sw		 bit (1) aligned;

	dcl     1 auto_deliver_options like deliver_options;
	dcl     1 auto_format_message_options like format_message_options;
	dcl     1 auto_format_document_options like format_document_options;
	dcl     1 auto_message_body_section_parameter automatic like message_body_section_parameter;
	dcl     1 auto_parse_text_options like parse_text_options;
	dcl     1 auto_reply_options	 like reply_options;

/* ENTRIES */

	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35));
	dcl     emacs_		 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     format_document_$string entry (char (*), char (*), fixed bin (21), ptr, fixed bin (35));
	dcl     get_pdir_		 entry () returns (char (168));
	dcl     get_system_free_area_	 entry () returns (ptr);

	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$ioa_switch_nnl	 entry () options (variable);
	dcl     ioa_$nnl		 entry options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     mail_system_$add_body_section entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$deliver_message entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mail_system_$free_address_list entry (ptr, fixed bin (35));
	dcl     mail_system_$free_message entry (ptr, fixed bin (35));
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$replace_bcc entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$replace_cc entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$replace_reply_to entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$replace_to entry (ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$create_reply_message entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$format_address_list_field entry (character (*) varying, ptr, fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     mlsys_utils_$format_message entry (ptr, ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
          dcl     mlsys_utils_$format_text_field entry
                  (character (*) varying, character (*), bit (1) aligned, fixed binary, pointer, fixed binary (21),
	fixed binary (21), fixed binary (35));
	dcl     mlsys_utils_$free_delivery_results entry (ptr, fixed bin (35));
	dcl     mlsys_utils_$parse_address_list_text entry (character (*), ptr, character (8), ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$print_address_list_field entry (char (*) var, ptr, fixed bin, ptr, fixed bin (35));
	dcl     mlsys_utils_$print_delivery_results entry (ptr, bit (1) aligned, ptr, fixed bin (35));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
          dcl     user_info_ entry (char(*));
	dcl     xmail_display_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_error_$no_code	 entry options (variable);
	dcl     xmail_error_$no_print	 entry options (variable);
	dcl     xmail_error_$code_first entry options (variable);
	dcl     xmail_file_msgs_$single_msg entry (ptr, char (32) var, bit (1) aligned);
	dcl     xmail_file_msgs_$original_and_reply entry (ptr, ptr, char (32) var, bit (1) aligned);
	dcl     xmail_get_str_	 entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_redisplay_$all	 entry ();
	dcl     xmail_redisplay_$menu	 entry ();
	dcl     xmail_reply_msg_$ssu_exit entry ();
	dcl     xmail_sw_$redisplay	 entry ();
	dcl     xmail_sw_$update_position entry (char (*));
	dcl     xmail_sw_$update_usage entry (char (*));
	dcl     xmail_value_$get	 entry (char (*), char (*) var, fixed bin (35));
	dcl     xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35));
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_window_manager_$set_menu_window_size entry (fixed bin, fixed bin (35));

	dcl     based_array		 (no_chars) char (1)
				 based (reply_seg_ptr);
	dcl     based_string	 char (no_chars) based (reply_seg_ptr);
	dcl     based_string_format	 char (no_chars_format) based (format_seg_ptr);
	dcl     based_string_orig	 char (no_chars_orig) based (orig_seg_ptr);
	dcl     based_string_view	 char (no_chars_view) based (view_seg_ptr);
	dcl     def_reply_string	 char (no_chars) based (defrepl_seg_ptr);

/* AREA */

	dcl     reply_msg_area	 area aligned based (reply_msg_area_ptr);

/* BUILTINS */

	dcl     (addr, after, before, char, codeptr, divide, decat, index, length, ltrim, null, rtrim, string, substr, sum) builtin;

/* INCLUDE FILES */

%include access_mode_values;
%page;
%include iox_modes;
%page;
%include format_document_options;
%page;
%include mlsys_address_list;
%page;
%include mlsys_deliver_info;
%page;
%include mlsys_field_names;
%page;
%include mlsys_format_options;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_message;
%page;
%include mlsys_parse_txt_options;
%page;
%include mlsys_reply_options;
%page;
%include star_structures;
%page;
%include terminate_file;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_data;
%page;
%include xmail_responses;
%page;
%include xmail_windows;
%page;
%include window_dcls;

/* BEGIN */

START:

/* Set ptrs to null and set up for cleanup & quit conditions */

	saved_menu_size = xmail_windows.menu.height;
	call window_$clear_window (iox_$user_output, (0));/* ignore code */
	more_than_one = "0"b;
	include_original, original_in_window = "0"b;
	reply_msg_area_ptr = get_system_free_area_ ();
	reply_seg_ptr, recipients_info_ptr, cc_list_ptr, bcc_list_ptr,
	     to_list_ptr, repl_message_ptr, iocb_ptr,
	     orig_seg_ptr, format_seg_ptr, view_seg_ptr = null ();
	defrepl_seg_ptr = null ();
	star_names_ptr = null ();
	star_entry_ptr = null ();
	sci_ptr = null ();
	delivery_results_need_cleanup = "0"b;

/*  See if there are any messages in the mailbox when reply option chosen */

	mailbox_ptr = P_mailbox_ptr;
	curr_msgsp = P_curr_msgs_ptr;
	if mailbox_ptr = null () | curr_msgsp = null ()
	then do;
		call ioa_ ("All messages have been discarded.");
		go to EXIT;
	     end;

	on condition (quit)
	     begin;
	          on reissue_query begin;
		          call window_$clear_window (iox_$user_output, (0));
			goto RETRY (opt);
			end;
		if xmail_window_manager_$quit_handler ()
		then do;
			call window_$clear_window (iox_$user_output, (0)); /* ignore code */
			call xmail_window_manager_$set_menu_window_size (saved_menu_size, code);
			call xmail_sw_$update_position ("");
			call xmail_sw_$redisplay ();
			call xmail_redisplay_$all ();
			call ioa_ ("Replying terminated.");
			call CLEAN_UP;
			goto EXIT;
		     end;
	     end;

	on condition (cleanup) call CLEAN_UP;
	xmail_data.reply_request = "1"b;
/* Create seg (for reply message) in process dir */

	call hcs_$make_seg ("", REPLY_SEG_NAME, "", RW_ACCESS_BIN, reply_seg_ptr, code);
	if code ^= 0 then do;			/*  If seg already exists set its bit count to zero */
		bit_count = 0;
		if code = error_table_$namedup | code = error_table_$segknown
		then call terminate_file_ (reply_seg_ptr, bit_count, TERM_FILE_BC, code);
		else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     end;

/* Create seg (to place in the being-replied-to-message) */

	call hcs_$make_seg ("", VIEW_SEG_NAME, "", RW_ACCESS_BIN, view_seg_ptr, code);
	if code ^= 0 then do;			/* If seg already exists set its bit count to zero */
		bit_count = 0;
		if code = error_table_$namedup | code = error_table_$segknown
		then call terminate_file_ (view_seg_ptr, bit_count, TERM_FILE_BC, code);
		else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     end;

	call iox_$attach_name (unique_chars_ ("0"b), iocb_ptr, "vfile_ " || rtrim (get_pdir_ ()) || ">" || rtrim (VIEW_SEG_NAME), codeptr (ENTRY_NAME), code);
	if code ^= 0 then
	     call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);

	call iox_$open (iocb_ptr, Stream_output, "0"b, code);
	if code ^= 0 then
	     call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);

/* Place the header & text of the message(s) being replied to in the 
  "VIEW_SEG_NAME" seg */

	call xmail_display_msgs_ (mailbox_ptr, curr_msgsp, iocb_ptr);

	if iocb_ptr ^= null ()
	then do;
		call iox_$close (iocb_ptr, (0));
		call iox_$detach_iocb (iocb_ptr, (0));
		call iox_$destroy_iocb (iocb_ptr, (0));
	     end;

/* Determine bit count of "VIEW_SEG_NAME" */

	call hcs_$status_mins (view_seg_ptr, type, bit_count_view, code);
	if code ^= 0
	then do;
		call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);

		call timer_manager_$sleep (4, SECONDS);
		goto pre_end;
	     end;

/* Establish length of "based_string_view " */

	no_chars_view = divide (bit_count_view, BITS_PER_CHAR, 17, 0);

/* Determine if the original is to appear in the upper window */

	call xmail_value_$get_with_default (ORIGINAL_IN_WINDOW, (YES), response, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT,
		"^/Unable to get a value for ""^a"" in the xmail value segment.", ORIGINAL_IN_WINDOW);
	if response = YES then original_in_window = "1"b;
	else original_in_window = "0"b;

/* Establish pathname of "reply_seg_name" in process dir */

	emacs_seg_path_name = rtrim (get_pdir_ ()) || ">" || REPLY_SEG_NAME;

/* Determine absolute pathname of the the emacs extention 
   (xmail_emacs_ext_main_) used by this procedure */

	if ext_ptr = null ()
	then do;
		call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "", ext_ptr, code);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
		call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code);
		if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
		ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT;

	     end;

/* Emacs extention will be called in the "reply" mode */

	for_type = "reply";

/* Set up reply and deliver options */

	recipients_info_n_lists = 3;			/* make room for bcc */

	allocate recipients_info in (reply_msg_area) set (recipients_info_ptr);
	recipients_info.area_ptr = get_system_free_area_ ();
	recipients_info.version = RECIPIENTS_INFO_VERSION_2;

	auto_reply_options.version = REPLY_OPTIONS_VERSION_2;
	auto_reply_options.to = null ();
	auto_reply_options.cc = null ();
	auto_reply_options.bcc = null ();
	auto_reply_options.flags.include_authors = "1"b;
	auto_reply_options.flags.include_self = "0"b;
	auto_reply_options.flags.mbz = "0"b;

	auto_deliver_options.version = DELIVER_OPTIONS_VERSION_2;
	auto_deliver_options.delivery_mode = ORDINARY_DELIVERY;
	auto_deliver_options.queueing_mode = ALWAYS_QUEUE_FOREIGN;
	auto_deliver_options.queued_notification_mode = NOTIFY_ON_ERROR;
	auto_deliver_options.flags.abort = "1"b;
	auto_deliver_options.flags.send_if_empty = "0"b;
	auto_deliver_options.flags.recipient_notification = "1"b;
	auto_deliver_options.flags.queue_mailing_lists = "0"b;

	auto_deliver_options.flags.mbz = "0"b;

/* See if reply is for more than one message */

	if curr_msgs.count > 1 then more_than_one = "1"b;

/* Loop based on the number of messages being replied to */

	default_save_file = "outgoing";
	do idx = 1 to curr_msgs.count;
	     message_num = curr_msgs.numbers (idx);

/* Determine ptr to message structure */

	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		     call mail_system_$read_message (mailbox_ptr, message_num, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
		end;
	     reply_msg_ptr = mailbox.messages (message_num).message_ptr;

/* Recipients are to be included in reply. Note that the user can actually
   modify, to any extent he wishes, the recipient list while in the editor */

	     auto_reply_options.flags.include_recipients = "1"b;

/* Create reply message structure */

	     repl_message_ptr = null ();

	     call mlsys_utils_$create_reply_message (reply_msg_ptr, addr (auto_reply_options), repl_message_ptr, code);
	     if repl_message_ptr ^= null ()
	     then do;
		     message_ptr = repl_message_ptr;
		     if message.to -> address_list.n_addresses = 0
		     then do;
			     call ioa_ ("You are trying to reply to your own message. Reply to message no. ^d terminated.", message_num);
			     go to pre_end;
			end;
		end;
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (5, SECONDS);
		     go to pre_end;
		end;


/* See if deferred reply exists for this message */

	     auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1;
	     auto_parse_text_options.area_ptr = reply_msg_area_ptr;
	     auto_parse_text_options.flags.list_errors = "0"b;
	     auto_parse_text_options.flags.validate_addresses = "0"b;
	     auto_parse_text_options.flags.include_invalid_addresses = "0"b;
	     auto_parse_text_options.flags.mbz = "0"b;

               call user_info_ (user_name); /* we might need this */
	                                                               /* to plug a name into the reply-to */

	     deferred_reply_exists = "0"b;
	     delete_def_reply = "0"b;
	     deferred_seg_name = unique_chars_ ((reply_msg_ptr -> message.header.message_id)) || ".reply";
	     call hcs_$star_ ((xmail_data.mail_dir), (deferred_seg_name), star_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, (0));
	     if star_entry_count = 1
	     then do;
		     call hcs_$make_seg ((xmail_data.mail_dir), (deferred_seg_name), "", RW_ACCESS_BIN, defrepl_seg_ptr, (0));
		     call hcs_$status_mins (defrepl_seg_ptr, type, bit_count, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);

			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		     if bit_count ^= 0 then do;
RETRY (2):			
			     opt = 2;
			     call ioa_$rsnnl ("A deferred reply for message ^d exists. Do you wish to use it? ", prompt_string, (0), message_num);
			     call xmail_get_str_$yes_no (prompt_string, yes_sw);
			     if yes_sw then do;
				     no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0);
				     reply_to_list_ptr = null;
				     based_string = def_reply_string;
				     if index(before(based_string, "Reply: || NL"), "Reply-To:") > 0 then do;
					call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "To:"), "Reply-To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, reply_to_list_ptr, parse_text_error_list_ptr, code);
					if code ^= 0 then do;
					     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
					     call timer_manager_$sleep (4, SECONDS);
					     goto pre_end;
					     end;
					end;
				     else do;
					format_reply = "";
					format_reply_length, buffer_size = length ("Reply-To:  ") + length(user_name);
					buffer_used = 0;
					call mlsys_utils_$format_text_field (REPLY_TO_FIELDNAME, rtrim(user_name), ("0"b),
					     format_reply_length, addr(format_reply), buffer_size, buffer_used, code);
					if code ^= 0 then do;
					     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
					     call timer_manager_$sleep (4, SECONDS);
					     goto pre_end;
					     end;
					no_chars = format_reply_length + length (NL) + no_chars;
					bit_count = BITS_PER_CHAR * no_chars;
					based_string = format_reply || NL || based_string;
					end;
			     call terminate_file_ (reply_seg_ptr, bit_count, TERM_FILE_BC, code);
			     delete_def_reply = "1"b;
			     deferred_reply_exists = "1"b;
			end;

		     else do;
RETRY (3):				
			opt = 3;
			     call xmail_get_str_$yes_no ("Do you wish to discard it? ", yes_sw);
			     if yes_sw then delete_def_reply = "1"b;
			end;
		end;
	     end;

	     if ^deferred_reply_exists then do;		/* create a reply */
		call query_for_include_original ();

/* Set length of based_string temporarily to 5000 chars */

		     no_chars = 5000;
		     no_used = 0;

/* Get name(s) of sender of message being replied to */

		     call mlsys_utils_$format_address_list_field (REPLY_TO_FIELDNAME, message.header.reply_to, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		     if no_used > length ("Reply-To:  ") then;
		     else do;
			based_string = substr (based_string, 1, no_used) || rtrim(user_name);
			no_used = no_used + length (user_name);
			end;
		     based_string = substr (based_string, 1, no_used) || NL;
		     no_used = no_used + length (NL);                        

		     call mlsys_utils_$format_address_list_field (TO_FIELDNAME, message.header.to, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		     based_string = substr (based_string, 1, no_used) || NL;
		     no_used = no_used + length (NL);

/* If there were secondary recipients in the original message then determine
  the recipient list and append it to based_string so that the user may 
  modify it via the editor  */

		     start_of_cc = no_used + 1;
		     call mlsys_utils_$format_address_list_field (CC_FIELDNAME, message.header.cc, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		     based_string = substr (based_string, 1, no_used) || NL;
		     no_used = no_used + length (NL);


/* If there were bcc recipients in the original message then determine
  the recipient list and append it to based_string so that the user may 
  modify it via the editor  */

		     start_of_bcc = no_used + 1;
		     call mlsys_utils_$format_address_list_field (BCC_FIELDNAME, message.header.bcc, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		     based_string = substr (based_string, 1, no_used) || NL;
		     no_used = no_used + length (NL);

		     based_string = substr (based_string, 1, no_used) || "Reply: " || NL;
		     no_used = no_used + length ("Reply: ") + length (NL);

/* If the original is to be included, include it here */

		     if include_original
		     then call insert_original_message;

		     bit_count = no_used * BITS_PER_CHAR;
		     call terminate_file_ (reply_seg_ptr, bit_count, TERM_FILE_BC, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
		end;

/* Remove "For help press Funtion Key 1 " from status window. */

	     reply_header = "Replying to message no." || ltrim (char (message_num));
	     call xmail_sw_$update_usage (reply_header);
	     call xmail_sw_$update_position ("------------------------------------------------------------------------------");

	     call xmail_sw_$redisplay ();

/* See if more then one message is being replied-to */

	     if more_than_one then
		based_string_view = decat (based_string_view, " #" || rtrim (ltrim (char (message_num))) || " (", "011"b);
	     based_string_view = decat (based_string_view, "Date:", "011"b);
	     bit_count_view = length (decat (based_string_view, "-----(" || ltrim (rtrim (char (message_num))) || ")-----", "110"b)) * BITS_PER_CHAR;
	     call terminate_file_ (view_seg_ptr, bit_count_view, TERM_FILE_BC, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     if original_in_window then
		call xmail_window_manager_$set_menu_window_size (2, code);
	     else
		call xmail_window_manager_$set_menu_window_size (1, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     call window_$clear_window (xmail_windows.menu.iocb, (0)); /* ignore code */
	     if original_in_window
	     then call ioa_$ioa_switch_nnl (xmail_windows.menu.iocb, "      *** Use  ESC l  to view previous page,  ESC h  to view next page ***");
	     call window_$clear_window (iox_$user_output, (0)); /* ignore code */
	     call ioa_ ("...Please wait for editor...");
						/* Suppress the original if necessary. */

	     if ^original_in_window
	     then do;
		     call terminate_file_ (view_seg_ptr, 0, TERM_FILE_BC, code);
		end;
						/* Call the editor now */

	     call emacs_ (iox_$user_output, (emacs_seg_path_name), ext_pname, addr (for_type), status);

	     call xmail_window_manager_$set_menu_window_size (saved_menu_size, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     if status = 1
	     then do;
		     deferred_seg_name = unique_chars_ ((reply_msg_ptr -> message.header.message_id)) || ".reply";
		     call hcs_$make_seg ((xmail_data.mail_dir), (deferred_seg_name), "", RW_ACCESS_BIN, defrepl_seg_ptr, code);
		     if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segknown then do;
			     call ioa_ ("Sorry, unable to save ""deferred reply"" for message ^d. ^/This is an internal error.", message_num);
			     if curr_msgs.count > 1 then call timer_manager_$sleep (4, SECONDS);
			     go to pre_end;
			end;

		     call hcs_$status_mins (reply_seg_ptr, type, bit_count, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG,
				ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;

		     call terminate_file_ (defrepl_seg_ptr, bit_count, TERM_FILE_BC, code);

/* Get number of chars in seg */

		     no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0);

		     def_reply_string = based_string;
		     call ioa_ ("Deferred reply for message ^d saved.", message_num);
		     if more_than_one then call timer_manager_$sleep (3, SECONDS);
		     delete_def_reply = "0"b;
		     go to pre_end;
		end;

	     if status ^= 0

	     then do;
		     call xmail_window_manager_$reconnect ();
		     call ioa_ ("Reply to message ^d terminated.", message_num);
		     if curr_msgs.count > idx
		     then do;
			     call ioa_$nnl ("^/Do you still wish to reply to message(s): ");
			     do idx2 = idx + 1 to curr_msgs.count;
				call ioa_$nnl (" ^d", curr_msgs.numbers (idx2));
			     end;			/* end do loop */
			     call xmail_get_str_$yes_no (" ? ", yes_sw);
			     if yes_sw then go to pre_end;
			     else call ioa_ ("Replying terminated.");
			end;
		     call CLEAN_UP;
		     goto EXIT;
		end;

	     call hcs_$status_mins (reply_seg_ptr, type, bit_count, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;
	     if bit_count <= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
	     no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0);

/* Delete deferred reply if one existed */

	     if delete_def_reply
	     then do;
		call delete_$ptr (defrepl_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, (0)); /* ignore code */
		delete_def_reply = "0"b;
		end;

	     to_list_ptr, cc_list_ptr, bcc_list_ptr = null ();

/* Add bcc handling */

	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "Reply:"), "bcc:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, bcc_list_ptr, parse_text_error_list_ptr, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

	     if bcc_list_ptr ^= null ()
	     then do;
		     call mail_system_$replace_bcc (message_ptr, bcc_list_ptr, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		end;

/* Add Reply-To handling */

	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "To:"), "Reply-To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, reply_to_list_ptr, parse_text_error_list_ptr, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

	     if reply_to_list_ptr ^= null ()
	     then do;
		     call mail_system_$replace_reply_to (message_ptr, reply_to_list_ptr, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		end;                                /*  reply-to handling */

/* cc handling */

	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "bcc:"), "cc:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, cc_list_ptr, parse_text_error_list_ptr, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

	     if cc_list_ptr ^= null ()
	     then do;
		     call mail_system_$replace_cc (message_ptr, cc_list_ptr, code);
		     if code ^= 0
		     then do;
			     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
			     call timer_manager_$sleep (4, SECONDS);
			     goto pre_end;
			end;
		end;

	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "cc:"), NL || "To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, to_list_ptr, parse_text_error_list_ptr, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

	     call mail_system_$replace_to (message_ptr, to_list_ptr, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

	     message_body_section_ptr = addr (auto_message_body_section_parameter.section);
	     auto_message_body_section_parameter.version =
		MESSAGE_BODY_SECTION_PARAMETER_VERSION_2;
	     message_preformatted_body_section.header.section_type =
		MESSAGE_PREFORMATTED_BODY_SECTION;
	     message_preformatted_body_section.header.section_n_lines = -1;
	     start_of_text = index (based_string, "Reply:") + length ("Reply:") + length (NL);
	     message_preformatted_body_section.text_ptr =
		addr (based_array (start_of_text));
	     message_preformatted_body_section.text_lth =
		length (substr (rtrim (based_string), start_of_text));

	     recipients_info.lists (*).recipients_result_list_ptr = null ();
	     recipients_info.lists (1).address_list_ptr = message.to;
	     recipients_info.lists (2).address_list_ptr = message.cc;
	     recipients_info.lists (3).address_list_ptr = message.bcc;

	     call mail_system_$add_body_section (repl_message_ptr, addr (auto_message_body_section_parameter), 1, code);
	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

	     call xmail_value_$get_with_default (ACKNOWLEDGE, (NO), acknowledge, code);
	     if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT,
		     "/^Unable to get a value for ""^a"" in the xmail value segment.", ACKNOWLEDGE);

	     if acknowledge = NO
	     then auto_deliver_options.flags.acknowledge = "0"b;
	     else if acknowledge = ASK
	     then do;
RETRY (4):		     
		     opt = 4;
		     call xmail_get_str_$yes_no ("Do you want your reply acknowledged?  ", yes_sw);
		     if yes_sw then auto_deliver_options.flags.acknowledge = "1"b;
		     else auto_deliver_options.flags.acknowledge = "0"b;
		end;
	     else if acknowledge = YES
	     then auto_deliver_options.flags.acknowledge = "1"b;
	     else call xmail_error_$code_first (error_table_$bad_segment, NAME, QUIT,
		     "^/An invalid value for ""^a"" was found in the xmail value segment.", ACKNOWLEDGE);

	     call mail_system_$deliver_message (repl_message_ptr, recipients_info_ptr, addr (auto_deliver_options), code);
	     delivery_results_need_cleanup = "1"b;
	     if code ^= 0 then do;
		     if code = mlsys_et_$no_a_permission
		     then call xmail_error_$no_code (code, NAME, CONTINUE, "You do not have permission to send message to at least one of the recipients.");
		     if n_failed_recipients > 0
		     then do;
			     call ioa_ ("Reply to message no.^d could not be sent.^/", message_num);
			     call ssu_$standalone_invocation (sci_ptr, "", "", null (), xmail_reply_msg_$ssu_exit, code1);
			     if code1 = 0 then call mlsys_utils_$print_delivery_results (sci_ptr, ERRORS_ONLY, recipients_info_ptr, code1);
			     else call xmail_error_$no_code (code1, NAME, LOG, "The reason cannot be printed due to an internal programming error");
			     call ssu_$destroy_invocation (sci_ptr);

			     if idx = curr_msgs.count then go to pre_end;

			     resp = "";
			     do while (resp = "");
				call xmail_get_str_ ("^/Press RETURN to continue; BREAK to stop.", "", "", "", resp);
			     end;
			     go to pre_end;
			end;
		     call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		     call timer_manager_$sleep (4, SECONDS);
		     goto pre_end;
		end;

/* Issue the statement that the reply was sent. */

	     call ioa_ ("Reply to message no. ^d  sent: ", message_num);
	     call mlsys_utils_$print_address_list_field ("To", to_list_ptr, USE_SCREEN_WIDTH, null, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""To:"" recipient(s).");

	     if cc_list_ptr ^= null
	     then do;
		     call mlsys_utils_$print_address_list_field ("cc", cc_list_ptr, USE_SCREEN_WIDTH, null, code);
		     if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""cc:"" recipient(s).");
		end;
	     else call ioa_ ("cc:  <None>");

/* Add for bcc */

	     if bcc_list_ptr ^= null
	     then do;
		     call mlsys_utils_$print_address_list_field ("bcc", bcc_list_ptr, USE_SCREEN_WIDTH, null, code);
		     if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""bcc:"" recipient(s).");
		end;
	     else call ioa_ ("bcc:  <None>");

/* Save the reply message for the user */

	     call xmail_value_$get (SAVE_MAILBOX, default_save_file, code);
	     if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT,
		     "^/Unable to get a value for ""^a"" in the xmail value segment.", SAVE_MAILBOX);

	     call xmail_value_$get (SAVE_MESSAGE, save_message, code);
	     if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT,
		     "^/Unable to get a value for ""^a"" in the xmail value segment.", SAVE_MESSAGE);

	     call xmail_value_$get (FILE_ORIGINAL, file_original, code);
	     if code ^= 0 then call xmail_error_$code_first (code, NAME, "q",
		     "^/Unable to get value for ""^a"" in the xmail value segment.", FILE_ORIGINAL);

	     if save_message = YES then do;
		     if file_original = YES then do;
			     if default_save_file = ASK
			     then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION);
			     else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
			end;
		     else if file_original = ASK then do;
RETRY (5):			     
			     opt = 5;
			     call xmail_get_str_$yes_no ("Do you wish to file the original before the reply?", yes_sw);
			     if yes_sw then do;
				     if default_save_file = ASK
				     then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION);
				     else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
				end;
			     else if default_save_file = ASK
						then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION);
				     else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
			end;
		     else if file_original = NO
		     then do;
			     if default_save_file = ASK
			     then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION);
			     else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
			end;
		     else call xmail_error_$code_first (error_table_$bad_segment, NAME, "q",
			     "^/An invalid value for ""^a"" was found in the xmail value segment.", FILE_ORIGINAL);
		end;
	     else if save_message = ASK
	     then do;
RETRY (6):		     
		     opt = 6;
		     call xmail_get_str_$yes_no ("Do you wish to save this reply? ", yes_sw);
		     if yes_sw then do;
			     if file_original = YES then do;
				     if default_save_file = ASK
				     then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION);
				     else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
				end;
			     else if file_original = ASK then do;
RETRY (7):				     
				     opt = 7;
				     call xmail_get_str_$yes_no ("Do you wish to file the original before the reply?", yes_sw);
				     if yes_sw then do;
					     if default_save_file = ASK
					     then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION);
					     else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
					end;
					     else if default_save_file = ASK
						then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION);
				     else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
				end;
			     else if file_original = NO
			     then do;
				     if default_save_file = ASK
				     then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION);
				     else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
				end;
			     else call xmail_error_$code_first (error_table_$bad_segment, NAME, "q",
				     "^/An invalid value for ""^a"" was found in the xmail value segment.", FILE_ORIGINAL);
			end;
		end;

	     else if save_message ^= NO
	     then call xmail_error_$code_first (error_table_$bad_segment, NAME, "q",
		     "^/An invalid value for ""^a"" was found in the xmail value segment.", SAVE_MESSAGE);

	     if idx ^= curr_msgs.count then call timer_manager_$sleep (4, SECONDS);

pre_end:

	     call MESSAGE_CLEAN_UP ();

	end;					/* end of do loop */

	call CLEAN_UP ();
EXIT:	return;

/* ENTRY POINTS */

ssu_exit: entry;

/* This entry doesn't do anything but it is called by ssu_$print_message */
/* which is called by mlsys_utils_$print_delivery_results.               */

	return;

/* INTERNAL PROCEDURES */

MESSAGE_CLEAN_UP: proc ();

	if repl_message_ptr ^= null ()
	then do;
		call mail_system_$free_message (repl_message_ptr, code);
		repl_message_ptr = null ();
	     end;
	if to_list_ptr ^= null ()
	then do;
		call mail_system_$free_address_list (to_list_ptr, code);
		to_list_ptr = null ();
	     end;
	if cc_list_ptr ^= null ()
	then do;
		call mail_system_$free_address_list (cc_list_ptr, code);
		cc_list_ptr = null ();
	     end;

/* Add for bcc */

	if bcc_list_ptr ^= null ()
	then do;
		call mail_system_$free_address_list (bcc_list_ptr, code);
		bcc_list_ptr = null ();
	     end;
	if recipients_info_ptr ^= null ()
	then do;
		if delivery_results_need_cleanup then do;
			call mlsys_utils_$free_delivery_results (recipients_info_ptr, code);
			if code ^= 0 then call xmail_error_$no_print (code, NAME, CONTINUE, "While cleaning up delivery results.");
		     end;
	     end;
	return;
     end MESSAGE_CLEAN_UP;

minus_suffix: proc (name, suffix) returns (char (*) var);

/* PARAMETERS */

	dcl     name		 char (*);
	dcl     suffix		 char (*);

/* AUTOMATIC */

	dcl     reverse_name	 char (length (name)) var;
	dcl     reverse_suffix	 char (length (suffix)) var;

/* BUILTINS */

	dcl     (after, index, length, reverse, rtrim) builtin;

	reverse_name = reverse (rtrim (name));
	reverse_suffix = reverse (rtrim (suffix));

	if index (reverse_name, reverse_suffix || ".") ^= 1
	then return (name);
	else return (reverse (after (reverse_name, reverse_suffix || ".")));

     end minus_suffix;

query_for_include_original: proc;

/* Determine if the original is to be included in the reply */

	call xmail_value_$get_with_default (INCLUDE_ORIGINAL, (NO), response, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, "q",
		"^/Unable to get a value for ""^a"" in the xmail value segment.", INCLUDE_ORIGINAL);

	if response = YES
	then include_original = "1"b;
	else if response = ASK
	then do;
RETRY (1):		
		opt = 1;
		call xmail_get_str_$yes_no ("Do you wish to include the original in this reply? ", yes_sw);
		if yes_sw then include_original = "1"b;
	     end;
	else include_original = "0"b;

	if include_original
	then do;

/* Create segs for the printable original message before and after indenting 
   and setup format_document_ options */

		call hcs_$make_seg ("", ORIG_SEG_NAME, "", RW_ACCESS_BIN, orig_seg_ptr, code);
		if code ^= 0 then do;		/* If seg already exists set its bit count to zero */
			bit_count = 0;
			if code = error_table_$namedup | code = error_table_$segknown
			then call terminate_file_ (orig_seg_ptr, bit_count, TERM_FILE_BC, code);
			else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
		     end;

		call hcs_$make_seg ("", FORMAT_SEG_NAME, "", RW_ACCESS_BIN, format_seg_ptr, code);
		if code ^= 0 then do;		/* If seg already exists set its bit count to zero */
			bit_count = 0;
			if code = error_table_$namedup | code = error_table_$segknown
			then call terminate_file_ (format_seg_ptr, bit_count, TERM_FILE_BC, code);
			else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM);
		     end;

/* Set up format_message options */

		auto_format_message_options.version = FORMAT_MESSAGE_OPTIONS_VERSION_1;
		auto_format_message_options.line_length = NO_WIDTH_LIMIT;
		auto_format_message_options.envelope_formatting_mode = DEFAULT_FORMATTING_MODE;
		auto_format_message_options.header_formatting_mode = DEFAULT_FORMATTING_MODE;
		auto_format_message_options.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE;
		auto_format_message_options.include_body = "1"b;

/* Set up format_document options */

		auto_format_document_options.version_number = format_document_version_2;
		auto_format_document_options.indentation = 4;
		auto_format_document_options.line_length = DEFAULT_WIDTH;
		string (auto_format_document_options.switches) = ""b;
		auto_format_document_options.galley_sw = "1"b; /* ... don't insert page breaks */
		auto_format_document_options.literal_sw = "1"b; /* ... don't recognize controls in the text */
		auto_format_document_options.dont_break_indented_lines_sw = "1"b; /* ... don't break lines which are indented */
		auto_format_document_options.dont_fill_sw = "1"b; /* ... don't fill */
		auto_format_document_options.syllable_size = 0;

	     end;

     end query_for_include_original;

insert_original_message: proc;

/* Internal procedure to format the original message into printable form,
   indent it, and then add it to the based_string in the reply segment
   for editing */

	start_of_orig = no_used + 1;
	no_chars_orig = 0;
GROW_MORE:
	call mlsys_utils_$format_message (reply_msg_ptr, addr (auto_format_message_options), orig_seg_ptr, no_chars, no_chars_orig, code);
	if code = error_table_$smallarg then do;
	     no_chars = no_chars + 5000;
	     goto GROW_MORE;
	     end;
	else if code ^= 0
	then do;
		call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		go to pre_end;
	     end;

	no_chars_format = no_chars;
	call format_document_$string (based_string_orig, based_string_format, no_chars_format, addr (auto_format_document_options), code);
	if code ^= 0
	then do;
		call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
		go to pre_end;
	     end;

/* Append indented original and add the number of characters */

	based_string = substr (based_string, 1, no_used) || based_string_format;
	no_used = no_used + no_chars_format;

/* Append a newline */

	based_string = substr (based_string, 1, no_used) || NL;
	no_used = no_used + length (NL);

	return;
     end insert_original_message;

CLEAN_UP: proc ();

	if sci_ptr ^= null
	then call ssu_$destroy_invocation (sci_ptr);
	xmail_data.reply_request = "0"b;
	call xmail_redisplay_$menu ();

	if delete_def_reply
	     then call delete_$ptr (defrepl_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, (0));

	if reply_seg_ptr ^= null ()
	then do;
		call delete_$ptr (reply_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, code);
		reply_seg_ptr = null ();
	     end;
	call MESSAGE_CLEAN_UP ();

	if iocb_ptr ^= null then do;
		call iox_$close (iocb_ptr, (0));	/* ignore code */
		call iox_$detach_iocb (iocb_ptr, (0));	/* ignore code */
		call iox_$destroy_iocb (iocb_ptr, (0)); /* ignore code */
	     end;

	if view_seg_ptr ^= null ()
	then do;
		call delete_$ptr (view_seg_ptr, DELETE_SEG_FORCE, NAME, (0)); /* ignore code */
		view_seg_ptr = null ();
	     end;

	if orig_seg_ptr ^= null ()
	then do;
		call delete_$ptr (orig_seg_ptr, DELETE_SEG_FORCE, NAME, (0)); /* ignore code */
		orig_seg_ptr = null ();
	     end;
	if format_seg_ptr ^= null ()
	then do;
		call delete_$ptr (format_seg_ptr, DELETE_SEG_FORCE, NAME, (0)); /* ignore code */
		format_seg_ptr = null ();
	     end;

	if star_names_ptr ^= null () then free star_names;/* order is important */
	if star_entry_ptr ^= null () then free star_entries;
	if recipients_info_ptr ^= null ()
	then do;
		free recipients_info in (reply_msg_area);
		recipients_info_ptr = null ();
	     end;
	return;
     end CLEAN_UP;

     end xmail_reply_msg_;




		    xmail_review_defers_.pl1        09/02/88  0759.6r w 09/02/88  0746.8       49743



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


/* Begin xmail_review_defers_ */
/* Written by R. Ignagni  1/7/82 

   83-07-07 DJ Schimke: Removed unreferenced dcl of date and declared
   addr, divide, null, rtrim, and sum builtin functions.

   83-10-06 DJ Schimke: Replaced all calls to xmail_get_str_ with calls to
   xmail_get_str_$yes_no.

   84-06-21 JAFalksen: replaced date_time_$fstime/convert_date_to_binary_
		with cv_fstime_
*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* The purpose of this proc is to see if there are deferred replies in the xmail        */
/* directory that are over a certain time limit. If so, the user is querired to see if  */
/* he/she wishes to review them. If so these  will be displayed and the user will be    */
/* asked if he/she wishes to delete them				        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

xmail_review_defers_: proc (file_type, file_suffix, delta);

/* Parameter */

	dcl     file_type		 char (*) parameter;
	dcl     file_suffix		 char (*) parameter;
	dcl     delta		 fixed bin;

/* External Static */

	dcl     iox_$user_output	 ptr ext static;

/* Constant */

	dcl     DELETE_SEG_FORCE	 bit (6) int static options (constant) init ("100100"b);
	dcl     NAME		 char (20) static options (constant) init ("xmail_review_defers_");
	dcl     N_MICROSECONDS_PER_DAY fixed bin (71) int static options (constant) init (86400000000); /* (60000000 * 60 * 24) */

/* Condition */

	dcl     cleanup		 condition;

/* Automatic */

	dcl     clock_now		 fixed bin (71);
	dcl     clock_then		 fixed bin (71);
	dcl     code		 fixed bin (35);
	dcl     difference		 fixed bin;
	dcl     idx		 fixed bin;
	dcl     prompt_string	 char (100) var;
	dcl     yes_sw		 bit (1) aligned;


	dcl     1 auto_status_branch	 like status_branch;

/* Entries */

	dcl     convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
	dcl     cv_fstime_		 entry (bit (36) aligned) returns (fixed bin (71));
	dcl     delete_$ptr		 entry (ptr, bit (6), char (*), fixed bin (35));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     hcs_$status_	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);

/* Builtin */

	dcl     (addr, divide, null, rtrim, sum) builtin;

/* Include */

%page;
%include access_mode_values;
%page;
%include status_structures;
%page;
%include star_structures;
%page;
%include xmail_data;
%page;
%include xmail_responses;

	star_entry_ptr, star_names_ptr = null;

	on condition (cleanup) call CLEANUP;

	call hcs_$star_ ((xmail_data.mail_dir), "*." || file_suffix, star_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, (0));
	if star_entry_count > 0
	then do;
	     call convert_date_to_binary_ ("", clock_now, code); /* get current time */
	     do idx = 1 to star_entry_count;
		call hcs_$status_ ((xmail_data.mail_dir), (rtrim (star_names (idx))), 0, addr (auto_status_branch), null (), code);
		clock_then = cv_fstime_ ((auto_status_branch.short.dtu));
		difference = divide ((clock_now - clock_then), N_MICROSECONDS_PER_DAY, 17, 0);
		if difference > delta
		then do;
		     call iox_$control (iox_$user_output, "reset_more", null (), (0));
		     call ioa_$rsnnl ("You have a deferred ^a at least ^d days old. Do you wish to review it? ", prompt_string, (0), file_type, difference);
		     call xmail_get_str_$yes_no (prompt_string, yes_sw);
		     if yes_sw then call review_this_seg;
		end;
	     end;					/* end of do loop */
	end;
	call CLEANUP;
	return;

review_this_seg:
     proc;
	dcl     seg_string		 char (siz) based (seg_ptr);
	dcl     siz		 fixed bin;
	dcl     seg_ptr		 ptr;
	dcl     no_of_bits		 fixed bin (24);

	call hcs_$make_seg ((xmail_data.mail_dir), (rtrim (star_names (idx))), "", RW_ACCESS_BIN, seg_ptr, (0));
	call hcs_$status_mins (seg_ptr, 1, no_of_bits, (0));
	siz = divide (no_of_bits, 9, 17, 0);
	call ioa_ ("^/^a ^/", seg_string);
	call iox_$control (iox_$user_output, "reset_more", null (), (0));
	call ioa_$rsnnl ("Do you wish to discard the deferred ^a? ", prompt_string, (0), file_type, code);
	call xmail_get_str_$yes_no (prompt_string, yes_sw);
	if yes_sw then call delete_$ptr (seg_ptr, DELETE_SEG_FORCE, NAME, (0));
     end review_this_seg;

CLEANUP: proc;

	if star_names_ptr ^= null () then free star_names;
	if star_entry_ptr ^= null () then free star_entries;

     end CLEANUP;
     end xmail_review_defers_;





		    xmail_select_file_.pl1          09/02/88  0759.6rew 09/02/88  0736.1      279063



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




/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Add a new entrypoint for when the user is allowed to read mail from
     other users' mailboxes ($foreign_mailboxes).
  2) change(86-01-28,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Establish an on unit for reissue_query so that the choice menu can be
     redrawn or the question which the user typed quit after can be repeated.
     TRs 18711 18974.
  3) change(86-06-02,Blair), approve(86-06-02,MCR7358),
     audit(86-06-04,RBarstad), install(86-06-04,MR12.0-1069):
     Rearrange code in get_menu_choice to keep track of which menu we selected
     create from, the one where create means a file name or the one where
     create means a user mbx. PBF.
  4) change(88-06-16,Blair), approve(88-07-27,MCR7931),
     audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098):
     Change the call that gets the file type from hcs_$status_minf to
     fs_util_$get_type so that we don't need 's' access on the containing
     directory.  This will allow us to access a mailbox through a link when
     that mailbox is in a dir to which we have no access.  Error list #141.
                                                   END HISTORY COMMENTS */


/*
			xmail_select_file_

	This program is called to select a file for processing.
	Input parameters give a text description of the type of
	file desired, the suffix, whether old and/or new files
	are acceptable.  A directory name, entry name prefix,
	and status code are returned.

	The file is intended to come from the xmail directory,
	and is so restricted in this version.  (General pathnames
	might someday be allowed.)  

	When new files are not allowed and only a single candidate
	exists in the xmail directory, it is returned without comment.
	In all other cases the user is asked to make the selection.
	This is first done with a simple prompt and text reply.
	By responding to the prompt with "??" the user can switch to
	menu selection from the available choices.

	Error Returns:

        0
	Dir & Prefix have been set for the file selected by the user.
	If New_ok was true the file may not exist.

        other
	The selection was unsuccessful for some reason.  A diagnostic
	will already have been issued about the problem, but not what
	is to be done about it.  Generally the caller should abort the
	current menu selection and let the user choose what to do next.

          There are three entrypoints:

               xmail_select_file_
	          allows the user to select a file as described above.

	     xmail_select_file_$exclude
	          allows the user to select a file as described above,
		excluding  certain names from the users list
		of possible selections.

	     xmail_select_file_$caller_msg
	          works like xmail_select_file_ except that the caller
		has control over the content of the filename prompt.
*/

/* Written February 1982 by Suzanne Krupp */
/* Modified:
   82-12-15 Dave Schimke: Changed the format of the list internal proc output
   to a multiple-column output more consistant with xmail_Mail_File_Maint_. 
   Also added a test for code = 0 before reporting a link inconsistency. This
   prevents messages of the type "A link points to nowhere" when in fact no
   link exists.

   83-05-31 Dave Schimke: Changed all references to the nonexistent error code
   error_table_$badarg to error_table_$bad_arg. TR15273
  
   83-09-14 Dave Schimke: Removed the restriction that files be single 
   component names since the code which creates files doesn't enforce this 
   anyway. This, however, required the addition of code to prevent "**.sv.mbx"
   from being selected as "**.mbx". TR11956 TR13411

   83-10-11 Dave Schimke: Replaced call to xmail_get_line with call to 
   xmail_get_str_. Added cleanup handler to free allocated structures.
   Added Create and Exists flags to the calling sequences. Create means
   the user selected create on the dynamic menu. Exists tells the state of
   the selected file ("1"b = file exists).

   84-09-06 JG Backs: Modified to allow lists as menus personalization option
   to be checked before prompt.

   84-10-26 JG Backs: Modified get_menu_choice internal procedure to indicate
   the caller needs to create a file if there are no menu items and lists 
   as menus personalization option is set to yes.

   84-10-31 JG Backs: Modified to check response from call to xmail_get_str 
   in MAIN procedure to make sure file name is not too long.

   85-01-06 JG Backs: Modified get_menu_choice and validate_file procedures
   to add calls to timer_manager_$sleep after printing some error messages if
   the lists as menus personalization option is set to yes.  This allows the
   message to remain on the screen long enough to read before the menu is
   redisplayed.  In get_menu_choice, two errors (unable to get a list of
   files or create a dynamic menu), were changed to interrupt processing if
   the lists as menus personalization option is set to yes.  Also added code
   in validate_file to test for incorrect access.  Bugfix.

   85-01-18 JG Backs: Modified all the calls to timer_manager_$sleep to delay
   5 seconds instead of 3 so the user has more time to read the message on
   the screen.  Audit change.

*/
xmail_select_file_: proc (File_type, Suffix, Default, Old_ok, New_ok, Dir, Prefix, Create, Exists, code);

	Own_msg = "0"b;
	Excluding_some_names = "0"b;
	call MAIN;
	return;

exclude: entry (File_type, Suffix, Default, Old_ok, New_ok, Exclude_array, Dir, Prefix, Create, Exists, code);

	Own_msg = "0"b;
	Excluding_some_names = "1"b;
	call MAIN;
	return;

caller_msg: entry (File_type, Suffix, Default, Old_ok, New_ok, Dir, Prefix, Caller_message, Create, Exists, code);

	Own_msg = "1"b;
	Excluding_some_names = "0"b;
	call MAIN;
	return;


foreign_mailboxes: entry (File_type, Suffix, Default, Old_ok, New_ok, Dir, Prefix, Caller_message, User, Exists, code);

	dcl     user_id		 char (60);
	dcl     foreign_user_addr_ptr	 ptr;          
          dcl     full_pathname          char (168);         
	dcl     mt_address_ptr         ptr;
          dcl     absolute_pathname_ entry (char(*), char(*), fixed bin(35));
	dcl     mlsys_et_$invalid_address_syntax fixed bin(35) ext static;

	code = 0;
	Dir = "";
	Prefix, entryname = "";
	Names_ptr, Dyn_menup, star_names_ptr, star_entry_ptr = null;
	N_names = 0;
	Selected_dir = xmail_data.mail_dir;
	Default_file = Default;
	User, Exists = "0"b;
	new_ok = New_ok;
	old_ok = Old_ok;

	Area_ptr = get_system_free_area_ ();

	on condition (cleanup) call CLEANUP;

	starname = "**." || Suffix;

	Cant_get_list = "0"b;

	call get_candidates (Selected_dir, starname, Names_ptr, N_names, code);

	if code = error_table_$nomatch then ;
	else if code ^= 0
	then do;
		Cant_get_list = "1"b;
		code = 0;
	     end;

	Prompt = get_caller_msg ();

	selecting = "1"b;
	do while (selecting);
RETRY (2):	     
	     opt = 2;
	     Selected_file = "";
	     if xmail_data.lists_as_menus & old_ok
	     then call get_menu_choice (Selected_file);	/* Always list as menu */
	     else do;
		     call xmail_get_str_ (Prompt, "", PROMPT_REPLIES_HELP, explain_question (),
			response);
		     if response = "??"
		     then call get_menu_choice (Selected_file);
/*		     else if search (response, INVALID_CHARS) ^= 0
		     then do;
			     call ioa_ ("The character ""^a"" is invalid in a ^a name.", substr (response, search (response, INVALID_CHARS), 1), File_type);
			     Selected_file = "";
			end;

		     else if length (response) > (VALID_LENGTH - length (Suffix) - 1)
		     then do;
			     call ioa_ ("The ""^a"" name is too long.", File_type);
			     Selected_file = "";
			end;                                   */
		     else Selected_file = response;
		end;

	     if Selected_file ^= ""
	     then do;
		if Selected_file = USER_MAILBOX
		     then do;
			     call xmail_get_str_ ("Enter user name of mailbox to be processed: ", "", PROMPT_REPLIES_HELP, "user_mailbox", response);

TRY_AGAIN:		     user_id = rtrim (response);
			     call mlsys_utils_$parse_address_text (rtrim (user_id), foreign_user_addr_ptr, code);
			     if code = mlsys_et_$invalid_address_syntax then do;
				if index (rtrim(response), "{") = 0 then do;
				     call absolute_pathname_ (rtrim(response), full_pathname, code);
				     if code = 0 then begin;
     dcl temp_address        char (length (rtrim (full_pathname)) + 6);
					 temp_address = "{mbx " || rtrim(full_pathname) || "}";
					 call mlsys_utils_$parse_address_text (temp_address, foreign_user_addr_ptr, code);
					 if code ^= 0 then do;
					      call xmail_error_$no_code (code, NAME, "i", "Can't locate a mailbox with this pathname, ^a.", response);
					      goto EXIT_FOREIGN_MAILBOX;
					      end;
					 end;
				      else do;
					 call xmail_error_$no_code (code, NAME, "i", "Can't locate a mailbox with this pathname, ^a.", response);
					 goto EXIT_FOREIGN_MAILBOX;
					 end;
				      end;
				 else do;
				      call ioa_ ("The character ""{"" is invalid in a mailbox name.");
				      goto EXIT_FOREIGN_MAILBOX;
				      end;
				 end;
			     else if code ^= 0 then do;                /* not a savebox or user */
				     call xmail_error_$no_code (code, NAME, "i", " Can't get a mail table address for this user ^a.", response);
				     goto EXIT_FOREIGN_MAILBOX;
				end;
			     call GET_PATHNAME (foreign_user_addr_ptr, code);
			     if code ^= 0 then do;
				     call xmail_error_$no_code (code, NAME, "i", "Can't get mail table address for this user_id, ^a.", response);
				     goto EXIT_FOREIGN_MAILBOX;
				end;
			     else do;
				     Prefix = rtrim (entryname);
				     selecting = "0"b;
				     User = "1"b;
				end;
			end;
		     else do;
			     call validate_file (Selected_file, Exists, code);
			     if code = 0
			     then do;
				     Prefix = rtrim (Selected_file);
				     Dir = Selected_dir;
				     selecting = "0"b;
				end;
			     else do;
				Selected_file = USER_MAILBOX;
				goto TRY_AGAIN;
				end;
			end;
		end;
	end;

EXIT_FOREIGN_MAILBOX:
	call CLEANUP;
	return;

GET_PATHNAME: procedure (P_address_ptr, code);

dcl  P_address_ptr	        pointer parameter;
dcl  code	        fixed binary (35) parameter;
dcl  mlsys_et_$no_address_pathname fixed bin(35) ext static;
dcl  address_type           fixed bin;

	call mail_system_$get_address_type (P_address_ptr, address_type, code);
	if code ^= 0 then return;

	if (address_type = INVALID_ADDRESS | address_type = NAMED_GROUP_ADDRESS | address_type = MAILING_LIST_ADDRESS | address_type = FOREIGN_ADDRESS | address_type = FORUM_ADDRESS) then do;
	     code = mlsys_et_$no_address_pathname;
	end;
	else if address_type = USER_MAILBOX_ADDRESS | address_type = LOGBOX_ADDRESS | address_type = SAVEBOX_ADDRESS | address_type = MAILBOX_ADDRESS then do;
	     call mail_system_$get_address_pathname (P_address_ptr, Dir, entryname, ((32)" "), code);

	end;
	else do;					/* *** mail table address */
	     call mail_system_$get_mail_table_address (P_address_ptr, mt_address_ptr, code);
	     if code = 0 then call GET_PATHNAME (mt_address_ptr, code);
	end;

     end GET_PATHNAME;


	/*** Global variables ***/

/* Parameter */

	dcl     Caller_message	 char (*);
	dcl     Cant_get_list	 bit (1) aligned;
	dcl     Create		 bit (1) aligned;
	dcl     Default		 char (*);
	dcl     Dir		 char (168);
	dcl     Exists		 bit (1) aligned;
	dcl     Exclude_array	 (*) char (32) aligned;
	dcl     File_type		 char (*);
	dcl     New_ok		 bit (1) aligned;
	dcl     Old_ok		 bit (1) aligned;
	dcl     Prefix		 char (32) var;
          dcl     User                   bit (1) aligned;
	dcl     Suffix		 char (*);

/* Automatic */

	dcl     Area_ptr		 ptr;
	dcl     Default_file	 char (32);
	dcl     Dyn_menup		 ptr;
	dcl     entryname		 char (32);
	dcl     Excluding_some_names	 bit (1) aligned;
	dcl     N_names		 fixed bin;
	dcl     Names_ptr		 ptr;
	dcl     new_ok		 bit (1) aligned;
	dcl     old_ok		 bit (1) aligned;
          dcl     opt                    fixed bin;
	dcl     Own_msg		 bit (1) aligned;
	dcl     Prompt		 char (256) var;
	dcl     Selected_dir	 char (168);
	dcl     Selected_file	 char (32);

/* Based */

	dcl     Based_area		 area based (Area_ptr);
	dcl     Names		 (N_names) char (32) aligned based (Names_ptr);

/* Condition */

	dcl     cleanup		 condition;
          dcl     reissue_query          condition;

	/*** Non-global ***/

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     response		 char (256) var;
	dcl     selecting		 bit (1) aligned;
	dcl     starname		 char (32);

/* Builtin */

	dcl     (index, length, null, rtrim, search, substr, sum)
				 builtin;

/* Entries */

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     mail_system_$get_address_pathname entry (ptr, char (*), char (*), char (*), fixed bin (35));
          dcl     mail_system_$get_address_type entry (pointer, fixed bin (17), fixed bin (35));
          dcl     mail_system_$get_mail_table_address entry (ptr, ptr, fixed bin(35));
	dcl     mlsys_utils_$parse_address_text entry (char (*), ptr, fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_get_str_	 entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var);

/* Static */

	dcl     DEFER		 char (5) init ("defer") int static options (constant);
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$nomatch	 fixed bin (35) ext static;
	dcl     INVALID_CHARS	 char (12) init ("<>#()[]{}*,;") int static options (constant);
	dcl     MLIST		 char (3) init ("mls") int static options (constant);
	dcl     NAME		 char (18) init ("xmail_select_file_") int static options (constant);
	dcl     SAVE		 char (6) init ("sv.mbx") int static options (constant);
	dcl     USER_MAILBOX	 char (14) init ("<user mailbox>") int static options (constant);
	dcl     VALID_LENGTH	 fixed bin init (32) int static options (constant);

MAIN: proc ();

      on reissue_query begin;
	 goto RETRY (opt);
	 end;

	code = 0;
	Dir = "";
	Prefix = "";
	Names_ptr, Dyn_menup, star_names_ptr, star_entry_ptr = null;
	N_names = 0;
	Selected_dir = xmail_data.mail_dir;
	Default_file = Default;
	Create, Exists = "0"b;
	new_ok = New_ok;
	old_ok = Old_ok;

	if ^new_ok & ^old_ok
	then do;
		code = error_table_$bad_arg;
		call xmail_error_$no_code (code, NAME, "c", "Cannot choose new or old file." ||
		     "^/This is an internal error.");
		goto EXIT;
	     end;

	Area_ptr = get_system_free_area_ ();

	on condition (cleanup) call CLEANUP;

	starname = "**." || Suffix;

	Cant_get_list = "0"b;

	call get_candidates (Selected_dir, starname, Names_ptr, N_names, code);

	if code = error_table_$nomatch
	then ;					/* Process this later */
	else if code ^= 0
	then do;
		Cant_get_list = "1"b;
		code = 0;
	     end;

	if ^new_ok				/* Must have at least 1 old file */
	then do;
		if code = error_table_$nomatch	/* No old files found */
		then do;
			call xmail_error_$no_code (0, NAME, "c", "You do not have any ^as.", File_type);
			goto EXIT;
		     end;
		else if N_names = 1			/* One old file found, choose it automatically */
		then do;
			Prefix = rtrim (Names (1));
			Dir = Selected_dir;
			if Suffix = SAVE | Suffix = MLIST | Suffix = DEFER /* Print msg only for certain files */
			then do;
				Exists = "1"b;
				call ioa_ ("The ^a ""^a"" automatically selected - it is your only one.", File_type, Prefix);
				call timer_manager_$sleep (5, "11"b);
			     end;
			goto EXIT;
		     end;
	     end;

	if Own_msg
	then Prompt = get_caller_msg ();
	else Prompt = get_default_msg ();

	selecting = "1"b;
	do while (selecting);
RETRY (1):    
	     opt = 1;
	     Selected_file = "";

	     if xmail_data.lists_as_menus & old_ok
	     then call get_menu_choice (Selected_file);	/* always list as menu */

	     else do;
		     call xmail_get_str_ (Prompt, "", PROMPT_REPLIES_HELP, explain_question (), response);

		     if response = ""
		     then Selected_file = Default_file;
		     else if response = "??"
		     then do;
			     if old_ok
			     then call get_menu_choice (Selected_file); /* wants to choose from menu */
			     else call list ();	/* just wants list */
			end;
		     else if search (response, INVALID_CHARS) ^= 0
		     then do;			/* filter garbage */
			     call ioa_ ("The character ""^a"" is invalid in a ^a name.", substr (response, search (response, INVALID_CHARS), 1), File_type);
			     Selected_file = "";
			end;

		     else if length (response) > (VALID_LENGTH - length (Suffix) - 1)
		     then do;			/* check length of response */
			     call ioa_ ("The ""^a"" name is too long", File_type);
			     Selected_file = "";
			end;

		     else Selected_file = response;

		end;

	     if Selected_file ^= ""			/* we have chosen a file */
	     then do;
		     call validate_file (Selected_file, Exists, code);
		     if code = 0
		     then do;
			     Prefix = rtrim (Selected_file);
			     Dir = Selected_dir;
			     selecting = "0"b;
			end;
		end;
	end;					/* do while */

EXIT:
	call CLEANUP;
	return;
     end MAIN;

get_candidates: proc (dir, starname, names_ptr, n_names, code);

/* Automatic */

	dcl     exclude_map		 (500) bit (1);
	dcl     i			 fixed bin;
	dcl     j			 fixed bin;
	dcl     seg_name		 char (32);

/* Based */

	dcl     names		 (n_names) char (32) based (names_ptr);

/* Entries */

	dcl     hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));

/* Parameter */

	dcl     code		 fixed bin (35);
	dcl     dir		 char (*);
	dcl     n_names		 fixed bin;
	dcl     names_ptr		 ptr;
	dcl     starname		 char (*);

	j = 0;
	code = 0;

	call hcs_$star_ (dir, starname, star_ALL_ENTRIES, Area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code);

	if code ^= 0				/* no match or other error */
	then return;

	do i = 1 to star_entry_count;
	     if exclude_this_segment (star_names (star_entries (i).nindex))
	     then exclude_map (i) = "1"b;
	     else do;
		     exclude_map (i) = "0"b;
		     n_names = n_names + 1;
		end;
	end;

	allocate names in (Based_area) set (names_ptr);

	do i = 1 to star_entry_count;
	     seg_name = star_names (star_entries (i).nindex);
	     if ^exclude_map (i)
	     then do;
		     j = j + 1;
		     names (j) = minus_suffix (seg_name, Suffix);
		end;
	end;

     end get_candidates;

minus_suffix: proc (name, suffix) returns (char (*) var);

/* Automatic */

	dcl     reverse_name	 char (length (name)) var;
	dcl     reverse_suffix	 char (length (suffix)) var;

/* Builtin */

	dcl     (after, index, length, reverse, rtrim) builtin;

/* Parameter */

	dcl     name		 char (*);
	dcl     suffix		 char (*);

	reverse_name = reverse (rtrim (name));
	reverse_suffix = reverse (rtrim (suffix));

	if index (reverse_name, reverse_suffix || ".") ^= 1
	then return (name);
	else return (reverse (after (reverse_name, reverse_suffix || ".")));

     end minus_suffix;

get_default_msg: proc () returns (char (256) var);

/* Automatic */

	dcl     prompt		 char (256) var;

	if new_ok & old_ok
	then call ioa_$rsnnl ("Enter a new or existing ^a name" || /* Msg for both new and old */
		"^[ (for ""^a"", press RETURN)^]: ",
		prompt, (0), File_type, Default_file ^= "", Default_file);
	else call ioa_$rsnnl ("Enter the name of ^[a new^;an existing^] ^a" || /* Msg for either new or old */
		"^[ (for ""^a"", press RETURN)^]: ",
		prompt, (0), new_ok, File_type, Default_file ^= "", Default_file);

	return (prompt);

     end get_default_msg;

get_caller_msg: proc () returns (char (256) var);

/* Automatic */

	dcl     prompt		 char (256) var;

	call ioa_$rsnnl ("^a^[ (for ""^a"" press RETURN)^]: ", prompt, (0), Caller_message, Default_file ^= "", Default_file);

	return (prompt);

     end get_caller_msg;

get_menu_choice: proc (filename);

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     filename		 char (*);
	dcl     index		 fixed bin;
	dcl     selected_create	 bit (1) aligned;

/* Builtin */

	dcl     null		 builtin;

/* Entries */

	dcl     xmail_dyn_menu_$create entry ((*) char (*) aligned, ptr, ptr, ptr, fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_dyn_menu_$create_w_trailer entry ((*) char (*) aligned, char (*), ptr, ptr, ptr, fixed bin (35));
	dcl     xmail_get_dyn_choice_	 entry (ptr, fixed bin, fixed bin (35));
	dcl     xmail_get_dyn_choice_$trailer entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));

	filename = "";

	if Cant_get_list
	then do;
		if xmail_data.lists_as_menus		/* interrupt if auto menu */
		then call xmail_error_$no_code (0, NAME, "i", "Unable to get a list of your ^as.", File_type);
		else call xmail_error_$no_code (0, NAME, "c", "Unable to get a list of your ^as.", File_type);
		return;
	     end;

/* If there are no menu items, a new file is allowed, and Display Lists As
   Menus option is yes, allow caller to create */

	if N_names = 0 & new_ok & xmail_data.lists_as_menus
	then do;
		filename = "";
		old_ok = "0"b;
		Default_file = "";
		Prompt = get_default_msg ();
		Create = "1"b;			/* caller should create */
		return;
	     end;

	if N_names = 0 & ^xmail_data.foreign_mailbox
	then do;
		call xmail_error_$no_code (0, NAME, "c", "You have no existing ^as.", File_type);
		if xmail_data.lists_as_menus		/* delay if automatic list */
		then call timer_manager_$sleep (5, "11"b);
		return;
	     end;

	if new_ok
	then call xmail_dyn_menu_$create_w_trailer (Names, "<Create new " || File_type || ">", Dyn_menup, null, Area_ptr, code);
	else if xmail_data.foreign_mailbox then
	     if N_names > 0
	     then call xmail_dyn_menu_$create_w_trailer (Names, "<user mailbox>", Dyn_menup, null, Area_ptr, code);
	     else do;
		     N_names = 1;
		     allocate Names in (Based_area) set (Names_ptr);
		     Names (1) = "<user mailbox>";
		     call xmail_dyn_menu_$create (Names, Dyn_menup, null, Area_ptr, code);
		end;
	else call xmail_dyn_menu_$create (Names, Dyn_menup, null, Area_ptr, code);

	if code ^= 0
	then do;
		if xmail_data.lists_as_menus
		then call xmail_error_$no_code (code, NAME, "i", "Unable to select a ^a via a menu.", File_type);
		else call xmail_error_$no_code (code, NAME, "c", "Unable to select a ^a via a menu.", File_type);
		return;
	     end;

	do while ("1"b);

	     selected_create = "0"b;

	     if new_ok | xmail_data.foreign_mailbox
	     then call xmail_get_dyn_choice_$trailer (Dyn_menup, index, selected_create, code);
	     else call xmail_get_dyn_choice_ (Dyn_menup, index, code);

	     if code ^= 0
	     then do;
		     call xmail_error_$no_code (code, NAME, "c", "Unable to use your ""^a"" selection.^/This is an internal error.", File_type);
		     if xmail_data.lists_as_menus	/* delay if automatic list */
		     then call timer_manager_$sleep (5, "11"b);
		end;
	     else do;
		     if selected_create
		     then do;
			if new_ok
			then do;
				filename = "";
				old_ok = "0"b;
				Default_file = "";
				Prompt = get_default_msg ();
				Create = "1"b;	/* caller should create */
			     end;
			else if xmail_data.foreign_mailbox
			     then filename = USER_MAILBOX;
			end;
		     else filename = Names (index);
		end;
	     return;
	end;					/* do while */

     end get_menu_choice;

list: proc ();

/* Automatic */

	dcl     index		 fixed bin;

/* Builtin */

	dcl     mod		 builtin;

/* Entries */

	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$nnl		 entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);

	if Cant_get_list
	then do;
		call xmail_error_$no_code (0, NAME, "c", "Unable to get a list of your ^as.", File_type);
		return;
	     end;

	if N_names = 0
	then do;
		call xmail_error_$no_code (0, NAME, "c", "You have no existing ^as.", File_type);
		return;
	     end;

	call ioa_ ("^/You have ^d ^as:", N_names, File_type);

	do index = 1 to N_names;
	     if (mod (index, 3) = 0)
	     then call ioa_$nnl ("^a^/", Names (index));
	     else call ioa_$nnl ("^26a", Names (index));
	end;
	call ioa_ ("^/");
     end list;

validate_file: proc (prefix, exists, code);

/* Automatic */

	dcl     filename		 char (32);
	dcl     link_type		 bit (1) aligned;
          dcl     entry_type             char (32);
	dcl     type		 fixed bin (2);

/* Builtin */

	dcl     rtrim		 builtin;

/* Entries */
	dcl     fs_util_$get_type      entry (char(*), char(*), char(*), fixed bin(35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);

/* Parameter */

	dcl     code		 fixed bin (35);
	dcl     exists		 bit (1) aligned;
	dcl     prefix		 char (*);

/* Static */

	dcl     error_table_$dirseg	 fixed bin (35) ext static;
	dcl     error_table_$namedup	 fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$no_info	 fixed bin (35) ext static;
	dcl     LINK		 fixed bin (2) init (0) int static options (constant);
	dcl     NO_CHASE		 fixed bin (1) init (0) int static options (constant);
	dcl     SEGMENT		 fixed bin (2) init (1) int static options (constant);

	code = 0;

	if Suffix = ""
	then filename = prefix;
	else filename = rtrim (prefix) || "." || Suffix;

	if exclude_this_segment (filename)
	then do;
		code = error_table_$noentry;
		call xmail_error_$no_code (code, NAME, "c", "This name must be excluded from your choice. ""^a""", prefix);
		goto EXIT_VALIDATE;
	     end;

	link_type = "0"b;

	call hcs_$status_minf (Selected_dir, filename, NO_CHASE, type, (0), code);

	if (code = 0) & (type = LINK)
	then do;
		call fs_util_$get_type (Selected_dir, filename, entry_type, code);
		link_type = "1"b;
	     end;

	if code = error_table_$noentry		/* Process this later */
	then do;
		exists = "0"b;
		if link_type			/* Check for inconsistency */
		then do;
			call xmail_error_$no_code (code, NAME, "c",
			     "Unable to use the ^a ""^a"" because of an inconsistency in your xmail directory." ||
			     "^/A link points to nowhere.", File_type, prefix);
			if xmail_data.lists_as_menus	/* delay if automatic list */
			then call timer_manager_$sleep (5, "11"b);

			goto EXIT_VALIDATE;
		     end;
	     end;
	else if code = error_table_$no_info
	then do;
		call xmail_error_$no_code (code, NAME, "c", " You do not have access to use the ""^a"" ^a.", prefix, File_type);
		if xmail_data.lists_as_menus		/* delay if automatic list */
		then call timer_manager_$sleep (5, "11"b);
		goto EXIT_VALIDATE;
	     end;
	else if code ^= 0
	then do;
		call xmail_error_$no_code (code, NAME, "c", "Unable to use the ^a ""^a"".^/This is an internal error.", File_type, prefix);
		if xmail_data.lists_as_menus		/* delay if automatic list */
		then call timer_manager_$sleep (5, "11"b);
		goto EXIT_VALIDATE;
	     end;
	else exists = "1"b;				/* code = 0 */

	if new_ok & old_ok				/* accept any name NEW or OLD */
	then do;
		code = 0;
		goto EXIT_VALIDATE;
	     end;

	if new_ok					/* Need a NEW file name */
	then do;
		if code = error_table_$noentry
		then do;
			code = 0;
			goto EXIT_VALIDATE;
		     end;
		else do;
			code = error_table_$namedup;
			call xmail_error_$no_code (code, NAME, "c", "The ^a name ""^a"" is already used." ||
			     "^/Please specify another name.", File_type, prefix);
			goto EXIT_VALIDATE;
		     end;
	     end;

	if code = error_table_$noentry		/* Must be OLD file */
	then do;
	          if ^xmail_data.foreign_mailbox
		then call xmail_error_$no_code (code, NAME, "c",
		     "Unable to use the ^a ""^a""." ||
		     " It does not exist.", File_type, prefix);
		goto EXIT_VALIDATE;
	     end;

	if (type ^= SEGMENT & entry_type ^= "mbx")
	then do;
		code = error_table_$dirseg;
		call xmail_error_$no_code (code, NAME, "c",
		     "Unable to use ""^a"".^/It is not of expected type (^a)." ||
		     "  This is an inconsistency in your xmail directory.", prefix, File_type);
		if xmail_data.lists_as_menus		/* delay if automatic list */
		then call timer_manager_$sleep (5, "11"b);
	     end;

EXIT_VALIDATE:
	return;

     end validate_file;



explain_question: proc returns (char (32) var);

/* Automatic */

	dcl     info_name		 char (32) var;

/* Builtin */

	dcl     translate		 builtin;

	call ioa_$rsnnl ("^[^4s^;^[^a^x^2s^;^s^[^a^x^;^s^]^]^]^a", info_name, (0), new_ok & old_ok, new_ok, "new", old_ok, "old", File_type);
	info_name = translate (info_name, "_", " ");
	return (info_name);
     end explain_question;

exclude_this_segment: proc (seg_name) returns (bit (1) aligned);

/* Automatic */

	dcl     exclude_flag	 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     match_code		 fixed bin (35);

/* Entry */

	dcl     match_star_name_	 entry (char (*), char (*), fixed bin (35));

/* Builtin */

	dcl     hbound		 builtin;

/* Parameter */

	dcl     seg_name		 char (*);

	exclude_flag = "0"b;

	if Suffix = "mbx" then do;
		call match_star_name_ (seg_name, "**.sv.mbx", match_code);
		if match_code = 0 then do;
			exclude_flag = "1"b;
			goto EXCLUDE_EXIT;
		     end;
	     end;

	if ^Excluding_some_names
	then goto EXCLUDE_EXIT;

	do i = 1 to hbound (Exclude_array, 1);
	     if seg_name = Exclude_array (i)
	     then do;
		     exclude_flag = "1"b;
		     goto EXCLUDE_EXIT;
		end;
	end;

EXCLUDE_EXIT:
	return (exclude_flag);

     end exclude_this_segment;

CLEANUP: proc ();

	dcl     xmail_dyn_menu_$free	 entry (ptr, fixed bin (35));
	dcl     cleanup_code	 fixed bin (35);

	if star_names_ptr ^= null () then free star_names;/* order is important */
	if star_entry_ptr ^= null () then free star_entries;
	if Names_ptr ^= null () then free Names;
	if Dyn_menup ^= null () then do;
		call xmail_dyn_menu_$free (Dyn_menup, cleanup_code);
		if cleanup_code ^= 0
		then call xmail_error_$no_print (cleanup_code, NAME, "c",
			"Unable to free the dynamic menu.");
	     end;
     end CLEANUP;

/* Include */

%include xmail_data;
%page;
%include xmail_help_infos;
%page;
%include star_structures;
%page;
%include mlsys_address_types;

     end xmail_select_file_;




		    xmail_select_msgs_.pl1          09/02/88  0759.6r w 09/02/88  0745.0      395892



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



/****^  HISTORY COMMENTS:
  1) change(86-02-06,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-02-28  JG Backs: Modified to allow selection of messages by date or
     range of dates.  Added 3 new internal procedures to do this: date_search,
     convert_date, and date_current.  Also added an include file for date
     conversions: time_value.incl.pl1 and clock builtin.
     85-03-11  JG Backs: Modified to allow responses of short forms of keywords.
     Allow a for all, l for last, f for first, n for next, and p for prev.
     Include file xmail_responses.incl.pl1 was also modified to add short forms.
  2) change(86-02-06,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Add new procs to process "new", "seen", and "unseen" selection specifiers.
     Note that the previous meaning of "new" is preserved in the new_current
     procedure whereas the new meaning of "new" (unseen since last seen)
     requires a new entrypoint.  The old is retained so that
     xmail_Process_Mail_ can update mail file counts as new messages arrive.
  3) change(86-02-25,Blair), approve(86-02-25,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Change the interpret_list routine so that swn seen and swf seen can
     be processed.  This required changes to when the message structure gets
     allocated for SEEN UNSEEN NEW and ALL messages.  It is now possible to
     process lists of messages in conjunction with ranges.
  4) change(87-01-14,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Initialize the count variable in new_current to alleviate a size error
     problem when we create a new current msgs structure.
                                                   END HISTORY COMMENTS */


xmail_select_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_seen_msgs, P_switch_on_off, P_pos_line);

/* BEGIN DESCRIPTION

history:
   Created 06/17/81 by Suzanne Krupp 

   83-07-14  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   84-11-09  JG Backs: Modified interpret_range internal procedure to make
   sure the largest number in the range is not above the number of messages
   in the mailbox. 

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     P_curr_msgsp	 ptr parameter;
	dcl     P_deleted_msgsp	 ptr parameter;
	dcl     P_mailbox_ptr	 ptr parameter;
	dcl     P_pos_line		 char (*) parameter;
	dcl     P_spec_msgsp	 ptr parameter;
          dcl     P_switch_on_off        bit (2) aligned parameter;
	dcl     P_seen_msgs                ptr;
		

/* AUTOMATIC */

	dcl     area_ptr		 ptr;
	dcl     code		 fixed bin (35);
          dcl     hold_code              fixed bin (35);
	dcl     i			 fixed bin;
	dcl     line		 char (256) var;
          dcl     list_any               bit (1) aligned;
	dcl     need_answer		 bit (1) aligned;
	dcl     n_new_msgs             fixed bin;
	dcl     prompt_sw		 bit (1) aligned;
          dcl     switch_on              bit (1) aligned;
          dcl     switch_off             bit (1) aligned;
	dcl     unused_return_length	 fixed bin;
	dcl     want_deleted_msgs	 bit (1) aligned;
	dcl     want_seen_messages     bit (1) aligned;
		

/* BASED */

	dcl     based_area		 area based (area_ptr);

/* BUILTINS */

	dcl     (addr, after, before, char, index, length, ltrim, null, rtrim, verify) builtin;

/* CONDITIONS */

          dcl     cleanup                condition;

/* CONSTANTS */

	dcl     DUMMY_ANSWER_ARRAY	 (1) char (1) var static options (constant) init ("");
	dcl     ME_CHAR		 char (17) int static options (constant) init ("xmail_select_msgs");
	dcl     ONE_DAY		 fixed binary (71) static options (constant) init (86399999999);  /* one microsecond less than 1 day */
	dcl     SECONDS                bit (2) int static options (constant) init ("11"b);
	dcl     TODAY		 char (5) int static options (constant) init ("today");
		

/* ENTRIES */

	dcl     com_err_$suppress_name entry () options (variable);
	dcl     convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin(35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     date_time_$format      entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
	dcl     date_time_$from_clock  entry (fixed bin(71), char(*), ptr, fixed bin(35));
	dcl     date_time_$to_clock    entry (ptr, fixed bin(71), fixed bin(35));
	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$read_new_messages entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (35));
	dcl     mlsys_utils_$search_message entry (ptr, char (*), ptr, fixed bin (35)) returns (bit (1) aligned);
	dcl     timer_manager_$sleep   entry (fixed bin(71), bit(2));
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_get_str_	 entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_list_msgs_	 entry (ptr, ptr, ptr);
	dcl     xmail_list_msgs_$selected entry (ptr, ptr, ptr);
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));

/* EXTERNAL STATIC */

	dcl     (mlsys_et_$no_more_messages,
	        xmail_err_$bad_response,
                  xmail_err_$int_prog_err,
	        xmail_err_$invalid_list,
	        xmail_err_$invalid_range,
	        xmail_err_$list_requested,
	        xmail_err_$mailbox_empty,
	        xmail_err_$no_msgs_exist,
	        xmail_err_$some_del_msgs_exist,
	        xmail_err_$some_msgs_exist,
	        xmail_err_$date_not_found,
	        xmail_err_$str_not_found) fixed bin (35) ext static;

	dcl     iox_$user_output	 ptr ext static;

/* INCLUDE FILES */

%page;
%include mlsys_message;
%page;
%include mlsys_mailbox;
%page;
%include time_value;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_prompts;
%page;
%include xmail_responses;
%page;
%include xmail_help_infos;
%page;
%include mlsys_search_options;
%page;
%include xmail_data;

/* Initialization */

	want_deleted_msgs, want_seen_messages, switch_on, switch_off, list_any = "0"b;
	P_switch_on_off = "00"b;
	P_seen_msgs = null;
	
	call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	need_answer = "1"b;
	do while (need_answer);

	     call xmail_get_str_ ((MSG_SELECT_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, MSG_SELECT_INFO, line);

	     code, count = 0;
	     curr_msgsp, nonexist_msgsp = null;

/* Look to see if more messages are in the mailbox.   */

	     call mail_system_$read_new_messages (mailbox_ptr, n_new_msgs, (0), (0), code);
	     if code ^= 0 & code ^= mlsys_et_$no_more_messages
		then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to look for new messages. This is an internal programming error.");
	     
	     hold_code = code;
	     code = 0;

	     if line = A | line = ALL | line = SEEN | line = UNSEEN | line = NEW 
               then call alloc_msg_struct (mailbox.n_messages, curr_msgsp);
                  
	     if line = ALL | line = A
	     then call all_current (count);
	     else if line = FIRST | line = F
	     then call first_current ();
	     else if line = LAST | line = L
	     then call last_current ();
	     else if line = NEXT | line = N
	     then call next_current (P_curr_msgsp);
	     else if line = PREV | line = P
	     then call prev_current (P_curr_msgsp);
	     else if line = NEW 
	     then call new_since_last_seen (count);
	     else if line = SEARCH
	     then call search (code);
	     else if line = SEEN
	     then call seen_current (count);
	     else if line = UNSEEN
	     then call unseen_current (count);
	     else if line = DATE
	     then call date_search (code);
/*	     else if index (line, ":") > 0
	     then call interpret_range (line, code); 
	     else if verify (line, "0123456789 ") = 0 
	     then call interpret_list (line, code); */
	     else if line = LIST
	     then code = xmail_err_$list_requested;
	     else call interpret_list (line,code);
	     
	     if code = 0				/* Everything ok */
	     then do;
		if line = A | line = ALL | line = NEW | line = SEEN | line = UNSEEN
		then curr_msgs.count = count;
		need_answer = "0"b;
		if ^(switch_on | switch_off)
		then call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, curr_msgs.numbers);
	     end;
	     else if code = xmail_err_$list_requested	/* User wanted a list */
	     then do;
		call ioa_ ("^/^a", MSG_LIST_MSG);
		call xmail_list_msgs_ (mailbox_ptr, P_curr_msgsp, iox_$user_output);
	     end;
	     else do;				/* Something went wrong */
		call com_err_$suppress_name (code, ME_CHAR);
		if code = xmail_err_$some_msgs_exist
		then do;
		     if want_some ()
		     then do;
			need_answer = "0"b;
			call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, curr_msgs.numbers);
		     end;
		end;
		else if code ^= xmail_err_$invalid_range &
		     code ^= xmail_err_$invalid_list &
		     code ^= xmail_err_$no_msgs_exist &
		     code ^= xmail_err_$str_not_found &
		     code ^= xmail_err_$date_not_found &
		     code ^= xmail_err_$bad_response
		then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to interpret response.  This is an internal programming error.");
	     end;

	     if need_answer				/* get rid of what we don't need. */
	     then if curr_msgsp ^= null then free curr_msgs;
	     if nonexist_msgsp ^= null then free nonexist_msgs;

	end;					/* do while */

          if switch_on | switch_off then P_seen_msgs = curr_msgsp;
	else
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	if switch_on then P_switch_on_off = "10"b;
	if switch_off then P_switch_on_off = "01"b;

	return;


/* ENTRYPOINTS */

all: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

          dcl  msg_count               fixed bin;

	want_deleted_msgs = "0"b;
	msg_count = 0;
	call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line);
	call alloc_msg_struct (mailbox.n_messages, curr_msgsp);
	call all_current (msg_count);
	P_pos_line = "all";
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	return;					/* all */

new: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	want_deleted_msgs = "0"b;

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error.");

	if P_curr_msgsp ^= null
	then do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	end;

	mailbox_ptr = P_mailbox_ptr;
	area_ptr = get_system_free_area_ ();

	if mailbox.n_messages = 0
	then do;
	     call use_spec_msgs (P_curr_msgsp, null);
	     P_pos_line = "NONE";
	     call xmail_error_$code_first (xmail_err_$mailbox_empty, ME_CHAR, "i");
	end;

          call mail_system_$read_new_messages (mailbox_ptr, n_new_msgs, (0), (0), code);
	if code ^= 0 & code ^= mlsys_et_$no_more_messages
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to look for new messages. This is an internal programming error.");

	call new_current (n_new_msgs, code);
	call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, curr_msgs.numbers);
						/*     P_pos_line = "newly arrived"; */
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	return;					/* first */

first: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	want_deleted_msgs = "0"b;

	call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line);
	call first_current ();
	P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1))));
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	return;					/* first */

last: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	want_deleted_msgs = "0"b;

	call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line);
	call last_current ();
	P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1))));
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	return;					/* last */

next: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	want_deleted_msgs = "0"b;

	call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line);
	call next_current (P_curr_msgsp);
	P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1))));
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	return;					/* next */

prev: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	want_deleted_msgs = "0"b;
	
	call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line);
	call prev_current (P_curr_msgsp);
	P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1))));
	call use_spec_msgs (P_curr_msgsp, curr_msgsp);

	return;					/* prev */

deleted: entry (P_mailbox_ptr, P_deleted_msgsp, P_flavor);

	dcl     P_flavor		 char (*) parameter;
          dcl     count                  fixed bin;

          count = 0;
	want_deleted_msgs = "1"b;
          switch_on, switch_off = "0"b;
	P_deleted_msgsp = null;

	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure.  This is an internal programming error.");

	if P_deleted_msgsp ^= null
	then do;
	     call xmail_validate_$curr_msgs (P_deleted_msgsp, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	end;

	mailbox_ptr = P_mailbox_ptr;
	area_ptr = get_system_free_area_ ();

	if mailbox.n_deleted_messages <= 0
	then do;
	     if ^xmail_data.cleanup_signalled
	     then call ioa_ ("There are no discarded messages.");
	     P_deleted_msgsp = null ();
	     return;
	end;
	if P_flavor ^= ""
	then do;
	     line = P_flavor;
	     prompt_sw = "0"b;
	end;
	else prompt_sw = "1"b;
	need_answer = "1"b;

	do while (need_answer);
	     if xmail_data.cleanup_signalled then do;
		prompt_sw = "0"b;
		line = ALL;
		end;
	     if prompt_sw
	     then call xmail_get_str_ ((DEL_MSG_SELECT_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, DEL_MSG_SELECT_INFO, line);

	     prompt_sw = "1"b;
	     code = 0;
	     curr_msgsp, nonexist_msgsp = null;

	     if line = ALL | line = A | line = NEW | line = SEEN | line = UNSEEN 
	     then call alloc_msg_struct (mailbox.n_messages, curr_msgsp);

	     if line = ALL | line = A
	     then do;
		count = 0;
		call all_current (count);
		curr_msgs.count = count;
		end;
	     else if line = FIRST | line = F
	     then call first_current ();
	     else if line = LAST | line = L
	     then call last_current ();
/*	     else if index (line, ":") > 0
	     then call interpret_range (line, code);
	     else if verify (line, "0123456789 ") = 0
	     then call interpret_list (line, code);      */
	     else if line = LIST
	     then code = xmail_err_$list_requested;
	     else call interpret_list (line,code);
	     
	     if code = 0
	     then need_answer = "0"b;
	     else if code = xmail_err_$list_requested
	     then do;				/* User requested a list */
		count = 0;
		call alloc_msg_struct (mailbox.n_messages, curr_msgsp);
		call all_current (count);
		curr_msgsp -> curr_msgs.count = count;
		call ioa_ ("^/^a^/", DEL_MSG_LIST_MSG);
		call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output);
	     end;
	     else do;
		call com_err_$suppress_name (code, ME_CHAR);
		if code = xmail_err_$some_del_msgs_exist
		then do;
		     if want_some ()
		     then need_answer = "0"b;
		end;
		else if code ^= xmail_err_$invalid_range &
		     code ^= xmail_err_$invalid_list &
		     code ^= xmail_err_$no_msgs_exist &
		     code ^= xmail_err_$bad_response
		then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to interpret user response. This is an internal programming error.");
	     end;

	     if need_answer
	     then if curr_msgsp ^= null
		then free curr_msgs;
	     if nonexist_msgsp ^= null
	     then free nonexist_msgs;

	end;

	P_deleted_msgsp = curr_msgsp;
	
	return;					/* deleted */

replace_curr: entry (P_curr_msgsp, P_spec_msgsp, P_pos_line);

	call use_spec_msgs (P_curr_msgsp, P_spec_msgsp);
	call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, P_curr_msgsp -> curr_msgs.numbers);

	return;					/* replace_curr */


/* INTERNAL PROCEDURES */

init: proc (P_mailbox_ptr, P_curr_msgsp, P_pos_line);

	dcl     (P_mailbox_ptr, P_curr_msgsp) ptr;
	dcl     P_pos_line		 char (*);

	dcl     code		 fixed bin (35);


	call xmail_validate_$mbx (P_mailbox_ptr, code);
	if code ^= 0
	then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error.");

	if P_curr_msgsp = null
	then ;
	else do;
	     call xmail_validate_$curr_msgs (P_curr_msgsp, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error.");
	end;

	mailbox_ptr = P_mailbox_ptr;
	area_ptr = get_system_free_area_ ();

	if mailbox.n_messages = 0
	then do;
	     call use_spec_msgs (P_curr_msgsp, null);
	     P_pos_line = "NONE";
	     go to INIT_EXIT;
	end;

	if mailbox.n_messages <= mailbox.n_deleted_messages
	then do;
	     call use_spec_msgs (P_curr_msgsp, null);
	     P_pos_line = "NONE";
	     call xmail_error_$no_code (code, ME_CHAR, "i");
	end;

INIT_EXIT: return;
     end init;

all_current: proc (P_count);

	dcl     P_count      fixed bin;
	dcl     i, count	 fixed bin;

          count = P_count;

	do i = 1 to mailbox.n_messages;
	     if want_deleted_msgs = msg_deleted (i)
	     then if ^already_specified (i, curr_msgsp)
	     then call add_to_msg_struct (curr_msgsp, count, i);
	end;

	P_count = count;

     end all_current;

first_current: proc ();

	call alloc_msg_struct (1, curr_msgsp);

	if want_deleted_msgs
	then curr_msgs.numbers (1) = first_deleted ();
	else curr_msgs.numbers (1) = first_existing ();

     end first_current;

last_current: proc ();

	call alloc_msg_struct (1, curr_msgsp);	

	if want_deleted_msgs
	then curr_msgs.numbers (1) = last_deleted ();
	else curr_msgs.numbers (1) = last_existing ();

     end last_current;

next_current: proc (P_curr_msgsp);

	dcl     P_curr_msgsp	 ptr;

	dcl     found		 bit (1) aligned;
	dcl     (i, highest)	 fixed bin;

	highest = 0;
	if P_curr_msgsp ^= null
	then do i = 1 to P_curr_msgsp -> curr_msgs.count;
		if highest < P_curr_msgsp -> curr_msgs.numbers (i)
		then highest = P_curr_msgsp -> curr_msgs.numbers (i);
	     end;


	call alloc_msg_struct (1, curr_msgsp);
	found = "0"b;

	do i = highest + 1 to mailbox.n_messages while (^found);	
	     if ^msg_deleted (i)
	     then do;
		curr_msgs.numbers (1) = i;
		found = "1"b;
	     end;
	end;

	do i = 1 to highest while (^found);
	     if ^msg_deleted (i)
	     then do;
		curr_msgs.numbers (1) = i;
		found = "1"b;
	     end;
	end;

     end next_current;

prev_current: proc (P_curr_msgsp);

	dcl     P_curr_msgsp	 ptr;

	dcl     found		 bit (1) aligned;
	dcl     (i, lowest)		 fixed bin;

	lowest = mailbox.n_messages + 1;

	if P_curr_msgsp ^= null
	then do i = 1 to P_curr_msgsp -> curr_msgs.count;
		if lowest > P_curr_msgsp -> curr_msgs.numbers (i)
		then lowest = P_curr_msgsp -> curr_msgs.numbers (i);
	     end;

	call alloc_msg_struct (1, curr_msgsp);
	found = "0"b;

	do i = lowest - 1 to 1 by -1 while (^found);
	     if ^msg_deleted (i)
	     then do;
		curr_msgs.numbers (1) = i;
		found = "1"b;
	     end;
	end;

	do i = mailbox.n_messages to lowest by -1 while (^found);
	     if ^msg_deleted (i)
	     then do;
		curr_msgs.numbers (1) = i;
		found = "1"b;
	     end;
	end;

     end prev_current;

new_current: proc (P_new_msgs, P_code);

	dcl     P_code		 fixed bin (35);
          dcl     count                  fixed bin;
	dcl     i			 fixed bin;
	dcl     P_new_msgs		 fixed bin;


	if P_code = mlsys_et_$no_more_messages
	then call xmail_error_$code_first (P_code, ME_CHAR, "i");
	
	call alloc_msg_struct (P_new_msgs, curr_msgsp);
	count = 0;
		
	do i = mailbox.n_messages - P_new_msgs + 1 to mailbox.n_messages;
	     call mail_system_$read_message (mailbox_ptr, i, code);
	     if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is a n internal programming error.", i);
/*	     message_ptr = mailbox.messages (i). message_ptr;       */
	     call add_to_msg_struct (curr_msgsp, count, i);
	end;

     end new_current;

new_since_last_seen:  proc (P_count);
		  
            dcl  P_count                             fixed bin;
	  dcl  (count, i, first_unseen, last_seen) fixed bin;

            want_seen_messages = "0"b;		  
	  count = P_count;

	  do i = mailbox.n_messages by -1 to 1 while (want_seen_messages = msg_seen (i));
	       end;
	  last_seen = i;

	  if last_seen < mailbox.n_messages then do;
	       first_unseen = last_seen +1;
	       do i = first_unseen to mailbox.n_messages;
		  if ^already_specified (i, curr_msgsp)
		  then call add_to_msg_struct (curr_msgsp, count, i);
		  end;
	       end;
	  P_count = count;
	  
	  if count = 0
	  then call xmail_error_$no_code ((0), ME_CHAR, "i", "There are no ""new"" messages in this mailbox.");

     end new_since_last_seen;

seen_current:  proc(P_count);
	     
               dcl     P_count           fixed bin;
	     dcl     (count,i)         fixed bin;

	     want_seen_messages = "1"b;
	     count = P_count;
	     
	     do i = 1 to mailbox.n_messages;
		if want_seen_messages = msg_seen(i)
		then if ^already_specified (i, curr_msgsp)
		then call add_to_msg_struct (curr_msgsp, count, i);
		end;
	     
	     P_count = count;

	     if count = 0 
	     then	call xmail_error_$no_code ((0),ME_CHAR,"i","There are no ""seen"" messages in this mailbox.");
	     end seen_current;

unseen_current: proc (P_count);
	      
	      dcl     P_count       fixed bin;
	      dcl     (count,i)     fixed bin;

	      want_seen_messages = "0"b;
	      count = P_count;
	      
	      do i = 1 to mailbox.n_messages;
		 if want_seen_messages = msg_seen (i)
		      then if ^already_specified (i, curr_msgsp)
		      then call add_to_msg_struct (curr_msgsp, count ,i);
		 end;
	      
	      P_count = count;

	      if count = 0 
                then call xmail_error_$no_code ((0), ME_CHAR, "i", "There are no ""unseen"" messages in this mailbox.");
	      	      
	      end unseen_current;

interpret_range: proc (P_str,P_left_num, P_right_num, P_code);

	dcl     P_str		 char (*) var;
          dcl     P_left_num             fixed bin;
          dcl     P_right_num            fixed bin;
	dcl     P_code		 fixed bin (35);

	dcl     (curr_count, nonexist_count) fixed bin;
	dcl     (left_num, right_num)	 fixed bin;
	dcl     (left_str, right_str)	 char (length (P_str)) var;
	dcl     code		 fixed bin (35);

	P_code = 0;
	left_str = ltrim (rtrim (before (P_str, ":")));
	right_str = ltrim (rtrim (after (P_str, ":")));

	if left_str = "" | right_str = ""
	then do;
	     P_code = xmail_err_$invalid_range;
	     go to RANGE_EXIT;
	end;

	left_num = get_num ((left_str), code);
	if code ^= 0
	then do;
	     P_code = xmail_err_$invalid_range;
	     go to RANGE_EXIT;
	end;

	right_num = get_num ((right_str), code);

	if code ^= 0
	then do;
	     P_code = xmail_err_$invalid_range;
	     go to RANGE_EXIT;
	end;

	if left_num > right_num
	then do;
	     P_code = xmail_err_$invalid_range;
	     go to RANGE_EXIT;
	end;

/* None of the specified messages exist. */

	if right_num < 1 | left_num > mailbox.n_messages
	then do;
	     P_code = xmail_err_$no_msgs_exist;
	     go to RANGE_EXIT;
	end;

/* Test if right number is more that the total messages */

	if right_num > mailbox.n_messages
	then do;
	     P_code = xmail_err_$invalid_range;
	     go to RANGE_EXIT;
	end;

          P_left_num = left_num;
          P_right_num = right_num;

	if ^list_any then do;
	     curr_count, nonexist_count = 0;
	     call alloc_msg_struct (right_num - left_num + 1, curr_msgsp);
	     call alloc_msg_struct (right_num - left_num + 1, nonexist_msgsp);

	     do  i = left_num to right_num;
		if want_deleted_msgs = msg_deleted (i)
		then call add_to_msg_struct (curr_msgsp, curr_count, i);
		else call add_to_msg_struct (nonexist_msgsp, nonexist_count, i);
		end;
	     
	     call set_counts (curr_count, nonexist_count, P_code); 
	end;
     

RANGE_EXIT: return;
     end interpret_range;

interpret_list: proc (P_str, P_code);

	dcl     P_str		 char (*) var;
	dcl     P_code		 fixed bin (35);

	dcl     (copy_str)	 char (length (P_str)) var;
	dcl     (curr_count, nonexist_count) fixed bin;
	dcl     (msg_num, n_tokens, token_index) fixed bin;
	dcl     code		 fixed bin (35);
          dcl     first_token            fixed bin;
          dcl     now_in_struct          bit (1) aligned;
          dcl     have_range             bit (1) aligned;
	dcl     left_num               fixed bin;
          dcl     right_num              fixed bin;
	dcl     get_temp_segment_ entry (char(*), ptr, fixed bin(35));
          dcl     release_temp_segment_ entry (char(*), ptr, fixed bin(35));
	dcl     token_array_ptr        ptr;
	dcl     1 token_array          based (token_array_ptr) aligned,
	          2 Ntokens            fixed bin,
	          2 token              (0 refer (Ntokens)) char (10) var;
      
	token_array_ptr = null;
          have_range = "0"b;
	list_any = "1"b;
          left_num, right_num, n_tokens, first_token = 0;
	P_code, code = 0;
	copy_str = P_str;

	call get_temp_segment_ (ME_CHAR, token_array_ptr, code);
	if code ^= 0 then do;
	     code = xmail_err_$int_prog_err;
	     goto LIST_EXIT;
	     end;

	on cleanup begin;
	     if token_array_ptr ^= null
	     then call release_temp_segment_ (ME_CHAR, token_array_ptr, (0));
	     end;

	Ntokens = 1;
	token_array.token(Ntokens) = next_token (copy_str);
	do while (token_array.token(Ntokens) ^= "");
	    if index (token_array.token(Ntokens) ,":") > 0 then do;
	         call interpret_range ((token_array.token(Ntokens)), left_num, right_num, P_code);
		if P_code ^= 0
		then goto LIST_EXIT;
		n_tokens = n_tokens + (right_num - left_num);
		end;

	     Ntokens = Ntokens + 1;	     	
	     token_array.token(Ntokens) = next_token (copy_str);
	end;

/* what have we got here? */

     first_token = 1;
     if token_array.token(1) = "switch_on" | token_array.token(1) = "swn"
     then if token_array.token(2) = SEEN 
          then do;
	     switch_on = "1"b;
	     if Ntokens > 2 then first_token = 3;
	     end;
          else  do;
	     P_code = xmail_err_$bad_response;
	     goto LIST_EXIT;
	     end;
	
     if token_array.token(1) = "switch_off" | token_array.token(1) = "swf"
     then if token_array.token(2) = SEEN
	then do;
	     switch_off = "1"b;
	     if Ntokens > 2 then first_token = 3;
	     end;
          else do;
	     P_code = xmail_err_$bad_response;
	     goto LIST_EXIT;
	     end;

          if (switch_on | switch_off)
	then n_tokens = (Ntokens + n_tokens - 3);
	else n_tokens = (Ntokens + n_tokens -1);                             /* take off the "" */

     do token_index = first_token to Ntokens;
	if token_array.token(token_index) = SEEN |
	     token_array.token(token_index) = ALL | token_array.token(token_index) = A | 
	     token_array.token(token_index) = NEW | 
	     token_array.token(token_index) = UNSEEN
	     then n_tokens = mailbox.n_messages;
	end;

     call alloc_msg_struct (n_tokens, curr_msgsp);	
     call alloc_msg_struct (n_tokens, nonexist_msgsp);
     curr_count, nonexist_count = 0;

     do token_index = first_token to Ntokens while (token_array.token(token_index) ^= "");     
	now_in_struct = "0"b;
	if index (token_array.token(token_index), ":") > 0             /* we have a range */
		then have_range = "1"b;
	     else
	     if token_array.token(token_index) = LAST | token_array.token(token_index) = L      /* want the last msg */
	     then msg_num = get_num((token_array.token(token_index)), code);
	     else
	     if token_array.token(token_index) = FIRST | token_array.token(token_index) = F     /* want the first msg */
               then msg_num = get_num((token_array.token(token_index)), code);
	     else
               if verify (token_array.token(token_index), "0123456789") = 0   /* single msg number */
	     then msg_num = cv_dec_check_ ((token_array.token(token_index)), code); 
	     else
	     if token_array.token(token_index) = NEW then do;
	     call new_since_last_seen (curr_count);
	     now_in_struct = "1"b;
	     end;
	     else
	     if token_array.token(token_index) = SEEN then do;
	     call seen_current (curr_count);
	     now_in_struct = "1"b;
	     end;
	     else
	     if token_array.token(token_index) = UNSEEN then do;
	     call unseen_current (curr_count);
	     now_in_struct = "1"b;
	     end;
	     else
	     if token_array.token(token_index) = ALL | token_array.token(token_index) = A then do;
	     call all_current (curr_count);
	     now_in_struct = "1"b;
	     end;
	     else code = xmail_err_$invalid_list;

	     if code ^= 0
	     then do;
		P_code = xmail_err_$invalid_list;
		go to LIST_EXIT;
	     end;
	     if have_range 
		then do msg_num = left_num to right_num;
		if ^already_specified (msg_num, curr_msgsp)
		then if want_deleted_msgs = msg_deleted (msg_num)
		     then call add_to_msg_struct (curr_msgsp, curr_count, msg_num);
		     else call add_to_msg_struct (nonexist_msgsp, nonexist_count ,msg_num);
		     have_range = "0"b;
		     end;
	     else
	     if ^now_in_struct & (^already_specified (msg_num, curr_msgsp))
	     then do;
		if msg_num >= 1 & msg_num <= mailbox.n_messages
		then do;
		     if want_deleted_msgs = msg_deleted (msg_num)
		     then call add_to_msg_struct (curr_msgsp, curr_count, msg_num);
		     else call add_to_msg_struct (nonexist_msgsp, nonexist_count, msg_num);
		end;
		else call add_to_msg_struct (nonexist_msgsp, nonexist_count, msg_num);
		end;

	     end;

	     curr_msgs.count = curr_count;
	     call set_counts (curr_count, nonexist_count, P_code);

LIST_EXIT: 
	     if token_array_ptr ^= null then do;
		call release_temp_segment_ (ME_CHAR, token_array_ptr, (0));
		token_array_ptr = null;
		end;
	     return;
     end interpret_list;

search: proc (P_code);

	dcl     P_code		 fixed bin (35);
	dcl     search_str		 char (256) var;

	P_code = 0;

	search_str = "";
	do while (search_str = "");
	     call xmail_get_str_ ((SEARCH_STR_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, SEARCH_STR_INFO, search_str);
	end;

	call search_current ((search_str));

	if curr_msgs.count = 0
	then P_code = xmail_err_$str_not_found;

	return;
     end search;

search_current: proc (P_search_str);

	dcl     P_search_str	 char (*);

	dcl     i			 fixed bin;
	dcl     count		 fixed bin;
	dcl     msg_has_str		 bit (1) aligned;

	dcl     1 auto_search_options	 like search_options;

	auto_search_options.version = SEARCH_OPTIONS_VERSION_2;
	auto_search_options.regexp_search = "0"b;
	auto_search_options.case_insensitive = "0"b;
	auto_search_options.search_envelope = "1"b;
	auto_search_options.search_header = "1"b;
	auto_search_options.search_redistributions_list = "1"b;
	auto_search_options.search_body = "1"b;
	auto_search_options.mbz = "0"b;

	call alloc_msg_struct (mailbox.n_messages, curr_msgsp);
	count = 0;

	do i = 1 to mailbox.n_messages;
	     if ^msg_deleted (i)
	     then do;
		if mailbox.messages (i).message_ptr = null
		then do;
		     call mail_system_$read_message (mailbox_ptr, i, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", i);
		end;
		message_ptr = mailbox.messages (i).message_ptr;
		msg_has_str = mlsys_utils_$search_message (message_ptr, P_search_str, addr (auto_search_options), code);
		if code = 0
		then do;
		     if msg_has_str
		     then call add_to_msg_struct (curr_msgsp, count, i);
		end;
	     end;
	end;					/* do i = ... */

	curr_msgs.count = count;
	return;
     end search_current;

date_search: proc (P_code);

	dcl     P_code		 fixed bin (35);    /* output */

	dcl     ds_ascii_date_1	 char (22);         /* formatted */
	dcl     ds_ascii_date_2	 char (22);         /* formatted */
	dcl     ds_clock_value_1       fixed bin (71);    /* converted */
	dcl     ds_clock_value_2       fixed bin (71);    /* converted */
	dcl     ds_date_str_1	 char (256) var;    /* user input */
	dcl     ds_date_str_2	 char (256) var;    /* user input */

/* BEGIN */

	P_code = 0;
RESTART:	   
	ds_clock_value_1 = 0;
	ds_clock_value_2 = 0;

	do while (ds_clock_value_1 = 0);
	     ds_date_str_1 = "";
               call xmail_get_str_ ((DATE_1_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, DATE_INFO, ds_date_str_1);
	     if ds_date_str_1 = ""                        /* 1st date null, check 2nd */
	     then go to DATE2;
	     else ds_clock_value_1 = convert_date ((ds_date_str_1));
	end;

DATE2:
	do while (ds_clock_value_2 = 0);
	     ds_date_str_2 = "";
	     call xmail_get_str_ ((DATE_2_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, DATE_INFO, ds_date_str_2);

/* If there are two dates entered, make the 2nd date with 23:59 time */

	     if ds_date_str_1 ^= "" & ds_date_str_2 ^= "" 
	     then do;
		ds_clock_value_2 = convert_date ((ds_date_str_2));
		if ds_clock_value_2 ^= 0
		then ds_clock_value_2 = ds_clock_value_2 + ONE_DAY;
	     end;
	                                                  
/* If both dates are null, use current date with 00:00 time as 1st clock
   date.  The 2nd date will be current date with 23:59 time.  */

	     else if ds_date_str_1 = "" & ds_date_str_2 = "" /* both null */
	     then do;
		ds_date_str_1 = TODAY;
		ds_clock_value_1 = convert_date ((ds_date_str_1));
	          if ds_clock_value_1 ^= 0
                    then ds_clock_value_2 = ds_clock_value_1 + ONE_DAY;  /* add one day minus one microsecond to get the full day. */
	     end;

/* If either dates are null, make the entered date the 1st clock 
   date with 00:00 time.  The 2nd clock date will be the same 
   date with 23:59 time.  */

               else do;
	          if ds_date_str_1 = "" & ds_date_str_2 ^= ""  /* 1st null */
    	          then ds_clock_value_1 = convert_date ((ds_date_str_2));
	          else ds_clock_value_1 = convert_date ((ds_date_str_1));

                    if ds_clock_value_1 ^= 0
                    then ds_clock_value_2 = ds_clock_value_1 + ONE_DAY;  /* add one day minus one microsecond to get the full day of the 1st date */
	     end;
	end;                                              /* do while */

/* Convert new clock values to ascii date strings for message to user */

          ds_ascii_date_1 = date_time_$format ("^my/^dm/^yc  ^Hd:^MH ^xxxxza", (ds_clock_value_1), "", "");
          ds_ascii_date_2 = date_time_$format ("^my/^dm/^yc  ^Hd:^MH ^xxxxza", (ds_clock_value_2), "", "");

	if ds_clock_value_1 >= ds_clock_value_2           /* check if dates backwards */
	then do;
	     call ioa_ ("The range of ^/  ""^a"" thru ""^a"" is empty or backwards.", ds_ascii_date_1, ds_ascii_date_2);
	     go to RESTART;
	end;

	call ioa_ ("Selecting messages from ^/  ""^a"" thru ""^a"".", ds_ascii_date_1, ds_ascii_date_2);
	call timer_manager_$sleep (8, SECONDS);           /* let user read */
	
	call date_current ((ds_clock_value_1), (ds_clock_value_2));

	if curr_msgs.count = 0
	then P_code = xmail_err_$date_not_found;

	return;
     end date_search;

/* Internal function to convert a date string into a clock value
   and clear out the time to 00:00 (midnight).         */

convert_date: proc (P_date_string) returns (fixed bin (71));

	dcl     P_date_string          char (*);          /* input */

	dcl     cd_clock_value         fixed bin (71);    /* output */
	dcl     cd_code                fixed bin (35);

	cd_clock_value = 0;
	Ptime_value = null;                               /* clear ptr */

	call convert_date_to_binary_ ((P_date_string), cd_clock_value, cd_code);
          if cd_code ^= 0 
          then do;
	     call ioa_ ("There is something wrong with the date or time as entered. ^/  Try again or use ? to get help.");
	     go to cd_EXIT;
	end;

/* Zero out the time */

          allocate time_value in (based_area);
	time_value.version = Vtime_value_3; 

	call date_time_$from_clock ((cd_clock_value), "", addr (time_value), cd_code);
          if cd_code ^= 0 
          then do;
               call ioa_ ("There is a problem with converting the date entered. ^/  Try again or use ? to get help.");
	     go to cd_EXIT;
	end;

/* Zero out all but day in calendar value to get date with zero time */

          time_value.yc = 0;      
	time_value.my = 0;
	time_value.dm = 0;
	time_value.Hd = 0;
	time_value.MH = 0;
	time_value.SM = 0;
	time_value.US = 0;
	time_value.fw = 0;
	time_value.dw = 0;
	time_value.dy = 0;
	time_value.Uc = 0;
	time_value.leap_year = 0;

	call date_time_$to_clock (addr (time_value), cd_clock_value, cd_code);
          if cd_code ^= 0 
          then do;
	     call ioa_ ("There is a problem with converting the date entered. ^/  Try again or use ? to get help.");
	     go to cd_EXIT;
	end;
	
cd_EXIT:
	if Ptime_value ^= null then free time_value;      /* free if allocated */
	return (cd_clock_value);
     end convert_date;

date_current: proc (P_clock_value_1, P_clock_value_2);

	dcl     P_clock_value_1	 fixed bin (71);    /* input */
	dcl     P_clock_value_2	 fixed bin (71);    /* input */

	dcl     i			 fixed bin;
	dcl     dc_count		 fixed bin;

	call alloc_msg_struct (mailbox.n_messages, curr_msgsp);
	dc_count = 0;

	do i = 1 to mailbox.n_messages;
	     if ^msg_deleted (i)
	     then do;
		if mailbox.messages (i).message_ptr = null
		then do;
		     call mail_system_$read_message (mailbox_ptr, i, code);
		     if code ^= 0
		     then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", i);
		end;
		message_ptr = mailbox.messages (i).message_ptr;

/* Test if date created in message header is between 1st and 2nd date/time */

		if (message.date_time_created >= P_clock_value_1) & (message.date_time_created <= P_clock_value_2)
		
		then call add_to_msg_struct (curr_msgsp, dc_count, i);
	     end;
	end;					/* do i = ... */

	curr_msgs.count = dc_count;
	return;
     end date_current;

next_token: proc (P_token_list) returns (char (*) var);

	dcl     P_token_list	 char (*) var;
	dcl     token		 char (length (P_token_list)) var;

	token = before (ltrim (P_token_list), " ");
	P_token_list = after (P_token_list, token);

	return (token);

     end next_token;

add_to_msg_struct: proc (P_msg_structp, P_count, P_msg_num);

	dcl     P_msg_structp	 ptr;
	dcl     (P_count, P_msg_num)	 fixed bin;

	msg_structp = P_msg_structp;
	P_count = P_count + 1;
	msg_struct.numbers (P_count) = P_msg_num;

	return;
     end add_to_msg_struct;

use_spec_msgs: proc (P_curr_msgsp, P_spec_msgsp);

	dcl     (P_curr_msgsp, P_spec_msgsp) ptr;

	if P_curr_msgsp ^= null then free P_curr_msgsp -> curr_msgs;
	P_curr_msgsp = P_spec_msgsp;

	return;
     end use_spec_msgs;

want_some: proc () returns (bit (1));

	dcl     yes_sw		 bit (1) aligned;

	call ioa_ ("^[^s^]^a", want_deleted_msgs, CURR_SET_MSG, CURR_DEL_SET_MSG);
	call ioa_ ("^(^-^d^/^)", curr_msgs.numbers);

	call xmail_get_str_$yes_no ((USE_SPEC_SET_PROMPT), yes_sw);

	return (yes_sw);

     end want_some;

msg_deleted: proc (P_msg_num) returns (bit (1));

	dcl     P_msg_num		 fixed bin;

	if mailbox.messages (P_msg_num).message_ptr = null
	then do;
	     call mail_system_$read_message (mailbox_ptr, P_msg_num, code);
	     if code ^= 0
	     then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", P_msg_num);
	end;
	message_ptr = mailbox.messages (P_msg_num).message_ptr;
	if message.marked_for_deletion
	then return ("1"b);
	else return ("0"b);

     end msg_deleted;

msg_seen: proc (P_msg_num) returns (bit (1));
	
	dcl   P_msg_num          fixed bin;
	
	if mailbox.messages (P_msg_num).message_ptr = null
	     then do;
	     call mail_system_$read_message (mailbox_ptr, P_msg_num, code);
	     if code ^= 0
		then call xmail_error_$no_code ( code, ME_CHAR, "l", "Unable to read message ^d. This is an interna;
	 programming error.", P_msg_num);
	     end;
	message_ptr = mailbox.messages (P_msg_num).message_ptr;
	if message.seen then return ("1"b);
	else return ("0"b);
	
	end msg_seen;

set_counts: proc (P_curr_count, P_nonexist_count, P_code);

	dcl     (P_curr_count, P_nonexist_count) fixed bin;
	dcl     P_code		 fixed bin (35);

	P_code = 0;

	if P_curr_count = 0				/* None of the specified messages exist. */
	then do;
	     free curr_msgs;
	     free nonexist_msgs;
	     P_code = xmail_err_$no_msgs_exist;
	     return;
	end;
	else curr_msgs.count = P_curr_count;

	if P_nonexist_count = 0			/* All exist. */
	then free nonexist_msgs;
	else do;					/* Some exist. */
	     nonexist_msgs.count = P_nonexist_count;
	     if want_deleted_msgs
	     then P_code = xmail_err_$some_del_msgs_exist;
	     else P_code = xmail_err_$some_msgs_exist;
	end;

	return;
     end set_counts;

alloc_msg_struct: proc (P_n_messages, P_msg_structp);

	dcl     P_n_messages	 fixed bin;
	dcl     P_msg_structp	 ptr;

	n_messages = P_n_messages;
	allocate msg_struct in (based_area);
	msg_struct.version = MSG_STRUCT_VERSION_1;
	P_msg_structp = msg_structp;

	return;
     end alloc_msg_struct;

get_num: proc (P_str, P_code) returns (fixed bin);

	dcl     P_code		 fixed bin (35);
	dcl     P_str		 char (*);

	P_code = 0;

	if P_str = FIRST | P_str = F
	then do;
	     if want_deleted_msgs
	     then return (first_deleted ());
	     else return (first_existing ());
	end;
	else if P_str = LAST | P_str = L
	then do;
	     if want_deleted_msgs
	     then return (last_deleted ());
	     else return (last_existing ());
	end;
	else return (cv_dec_check_ (P_str, P_code));

     end get_num;

first_existing: proc () returns (fixed bin);

	dcl     existing		 fixed bin;
	dcl     i			 fixed bin;

	existing = 0;
	do i = 1 to mailbox.n_messages while (existing = 0);
	     if ^msg_deleted (i) then existing = i;
	end;

	return (existing);

     end first_existing;

first_deleted: proc () returns (fixed bin);

	dcl     deleted		 fixed bin;
	dcl     i			 fixed bin;

	deleted = 0;
	do i = 1 to mailbox.n_messages while (deleted = 0);
	     if msg_deleted (i) then deleted = i;
	end;

	return (deleted);

     end first_deleted;

last_existing: proc () returns (fixed bin);

	dcl     existing		 fixed bin;
	dcl     i			 fixed bin;

	existing = 0;
	do i = mailbox.n_messages to -1 by -1 while (existing = 0);
	     if ^msg_deleted (i) then existing = i;
	end;

	return (existing);

     end last_existing;

last_deleted: proc () returns (fixed bin);

	dcl     deleted		 fixed bin;
	dcl     i			 fixed bin;

	deleted = 0;
	do i = mailbox.n_messages to 1 by -1 while (deleted = 0);
	     if msg_deleted (i) then deleted = i;
	end;

	return (deleted);

     end last_deleted;

already_specified: proc (P_msg_num, P_curr_msgsp) returns (bit (1));

	dcl     i			 fixed bin;
	dcl     P_curr_msgsp	 ptr;
	dcl     P_msg_num		 fixed bin;

	do i = 1 to P_curr_msgsp -> curr_msgs.count;
	     if P_msg_num = P_curr_msgsp -> curr_msgs.numbers (i)
	     then return ("1"b);
	end;

	return ("0"b);

     end already_specified;

   end xmail_select_msgs_;




		    xmail_send_mail_print_msg_.pl1  09/02/88  0759.6r w 09/02/88  0746.2       47151



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

/* Begin xmail_send_mail_print_msg_   */
/* Written by R. Ignagni    July 1981  

   83-06-20  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes. Changed code to use xmail_data.mail_dir rather than determining
   this pathname for itself.
*/
xmail_send_mail_print_msg_: proc ();

/*  Proc called as consequence of user having selected the "Print" option
in the Send Mail menu. The message is first placed in a temporary "screech" 
mailbox and then dprinted. It is initially placed in a mailbox so that the 
printing of all Exec Mail messages (from whatever menu) look exactly the same,
i.e., the format of a msg in mailbox.  */

/* Constant */

	dcl     CREATE_IF_NOT_FOUND	 bit (1) aligned static options (constant) init ("1"b);
	dcl     DELETE_SEG_FORCE_CHASE bit (6) static options (constant) init ("100101"b);
	dcl     NAME		 char (26) static options (constant) init ("xmail_send_mail_print_msg_");
	dcl     STOP		 char (1) static options (constant) init ("q");
	dcl     ERROR_MESSAGE	 char (65) static options (constant) init ("A program error has occurred. Cannot continue. Returning to menu.");

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     svmbx_dir		 char (168);
	dcl     temporary_mailbox_name char (15);

	dcl     1 auto_open_options	 like open_options;
	dcl     1 auto_close_options	 like close_options;

/* Entries */

	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     mail_system_$close_mailbox entry (ptr, ptr, fixed bin (35));
	dcl     mail_system_$open_mailbox entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35));
	dcl     mail_system_$save_message entry (ptr, char (*), char (*), bit (1) aligned, fixed bin (35));
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_dprint_msgs_	 entry (ptr, ptr);
	dcl     xmail_select_msgs_$first entry (ptr, ptr, char (*));

/*  Builtin  */

	dcl     (addr, null)	 builtin;

/* Error codes */

	dcl     mlsys_et_$savebox_created ext static fixed bin (35);

/* Conditions */

	dcl     (quit, cleanup)	 condition;

/* Include */

%page;
%include xmail_send_mail;
%page;
%include xmail_data;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_open_options;
%page;
%include mlsys_message;
%page;
%include xmail_curr_msg_info;
%page;
%include mlsys_close_options;
%page;

/* BEGIN */

	temporary_mailbox_name = unique_chars_ ("0"b);
	svmbx_dir = "";

	on condition (cleanup) call CLEAN_UP;
	on condition (quit)
	     begin;
		dcl     xmail_window_manager_$reconnect entry ();
		call xmail_window_manager_$reconnect ();
		call ioa_ ("""Print Sent Message"" terminated.");
		go to EXIT;
	     end;

/* See if message exits for "printing" */

	if send_mail_info.msg_exists = "0"b | send_mail_info.emacs_seg_ptr = null ()
	then do;
	     call ioa_ ("There is no message to print.");
	     go to EXIT;
	end;

	svmbx_dir = xmail_data.mail_dir;

/* Save msg the temporary mbx so it can be dprinted */

	call mail_system_$save_message (send_mail_info.new_msg_ptr, svmbx_dir, temporary_mailbox_name, CREATE_IF_NOT_FOUND, code);

	if code ^= 0 & code ^= mlsys_et_$savebox_created
	then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);

/* Open mbx */

	auto_open_options.version = OPEN_OPTIONS_VERSION_2;
	auto_open_options.message_selection_mode = ALL_MESSAGES;
	auto_open_options.sender_selection_mode = ALL_MESSAGES;
	auto_open_options.message_reading_level = READ_MESSAGES;
	mailbox_ptr = null ();
	call mail_system_$open_mailbox (svmbx_dir, temporary_mailbox_name || ".sv.mbx", addr (auto_open_options), MAILBOX_VERSION_2, mailbox_ptr, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);

/* Determine the msg ptr so that the xmail_dprint_msgs_ proc can be called to
   actully request the dprint of the msg */

	curr_msgsp = null ();
	call xmail_select_msgs_$first (mailbox_ptr, curr_msgsp, "");
	call xmail_dprint_msgs_ (mailbox_ptr, curr_msgsp);

/* Close mbx */

	auto_close_options.version = CLOSE_OPTIONS_VERSION_2;
	auto_close_options.flags.perform_deletions = "0"b;
	auto_close_options.flags.report_deletion_errors = "0"b;
	auto_close_options.flags.mbz = "0"b;
	call mail_system_$close_mailbox (mailbox_ptr, addr (auto_close_options), code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);

EXIT:	call CLEAN_UP;
	return;

CLEAN_UP: proc ();
	if svmbx_dir ^= ""
	then call delete_$path (svmbx_dir, temporary_mailbox_name || ".sv.mbx", DELETE_SEG_FORCE_CHASE, NAME, (0)); /* ignore code */
	return;
     end CLEAN_UP;

     end xmail_send_mail_print_msg_;




		    xmail_send_msg_.pl1             09/02/88  0759.6r w 09/02/88  0745.9      138015



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



/****^  HISTORY COMMENTS:
  1) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     85-04-01 JG Backs: Deleted the constant ASK because it was added to the
     include file xmail_responses.incl.pl1 and resulted in a compiler warning.
  2) change(86-01-07,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Rearrange code to print the stmt that the message was sent before
     querying the user about whether he wants to save the message.
  3) change(86-01-17,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Set the bit for cleanup_signalled on a quit condition (signalled by
     hitting break in response to *do you really want to quit*) so that the
     calling program will know that the message still exists. TR 20028.
  4) change(86-01-28,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Add an on unit for the reissue_query condition inside the quit handler so
     that questions which the user types break in response to can be reissued.
     TRs 18711 18974.
                                                   END HISTORY COMMENTS */


xmail_send_msg_: proc;

/* BEGIN DESCRIPTION

function:

   This proc delivers the message prepared by the user to the primary and
   (if any) the secondary recipients. It uses the mail_system_$deliver_message
   proc for this.  Optionally, it saves the delivered message. It is called as
   a consequence of the user selecting the "Send" option in the Send Mail Menu.

history:	

   81-07     Written by R. Ignagni, format: style1

   83-07-21  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.

   83-10-06  DJ Schimke: Replaced calls to xmail_get_str_ with calls to 
   xmail_get_str_$yes_no.

   83-11-23 DJ Schimke: Added support for the new personalization option
   "Outgoing Savefile" which allows selection of where to file save messages.
   This also solves the discrepancy between setting "Save Outgoing messages"
   to "yes" and never having set "Save Outgoing messages".

   83-12-07 DJ Schimke: Cleaned up the reporting of delivery results by calling
   mlsys_utils_$print_delivery_results_ and mlsys_utils_$print_address_field 
   for displaying the failure/success of sending. This module still needs 
   recovery code to allow the sender to correct the bad addresses and continue.

   83-12-08 DJ Schimke: Added simple flag to prevent the call to 
   mlsys_util_$free_delivery_results until the call to send the msg has been 
   made. Otherwise, this cleanup will get errors referencing invalid pointers.

   84-08-08 JG Backs: Modified for the addition of blind carbon copies.

   84-11-07 JG Backs: Deleted the input parameter P_caller, which was not used
   anywhere in module.  This also required modifying xmail_process_user_msgs_,
   which is the only other module that calls this module.  Audit change.



END DESCRIPTION
*/

/* CONSTANTS */

	dcl     ACKNOWLEDGE		 char (14) static options (constant) init ("acknowledge_yn");
	dcl     ALLOW_SELECTION	 bit (1) aligned static options (constant) init ("1"b);
	dcl     CONTINUE		 char (1) static options (constant) init ("c");
	dcl     ERROR_MESSAGE	 char (67) static options (constant) init ("Sending of message not completed, due to an internal program error.");
	dcl     ERRORS_ONLY		 bit (1) aligned static options (constant) init ("1"b);
	dcl     LOG		 char (1) static options (constant) init ("l");
	dcl     MAILFILE_SUFFIX	 char (6) static options (constant) init ("sv.mbx");
	dcl     NAME		 char (15) static options (constant) init ("xmail_send_msg_");
	dcl     NO_SELECTION	 bit (1) aligned static options (constant) init ("0"b);
	dcl     QUIT		 char (1) static options (constant) init ("q");
	dcl     SAVE_MAILBOX	 char (15) static options (constant) init ("save_mailfile");
	dcl     SAVE_MESSAGE	 char (15) static options (constant) init ("save_message_yn");
	dcl     USE_SCREEN_WIDTH	 fixed bin aligned static options (constant) init (-1);

/* AUTOMATIC */

	dcl     acknowledge		 char (3) var;
	dcl     code		 fixed bin (35);
	dcl     code1		 fixed bin (35);
	dcl     delivery_results_need_cleanup bit (1) aligned;
	dcl     opt                    fixed bin;
	dcl     save_file		 char (32) var;
	dcl     save_message	 char (3) var;
	dcl     sci_ptr		 ptr;
	dcl     send_area_ptr	 ptr;
	dcl     yes_sw		 bit (1) aligned;

	dcl     1 auto_deliver_options like deliver_options;

/* AREA */

	dcl     send_area		 area aligned based (send_area_ptr);

/* CONDITIONS */

	dcl     (cleanup, quit, reissue_query)	 condition;

/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr static external;
	dcl     mlsys_et_$no_a_permission ext static fixed bin (35);
	dcl     error_table_$bad_segment fixed bin (35) ext static;

/* ENTRIES */

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     ioa_		 entry () options (variable);
	dcl     mail_system_$deliver_message entry (ptr, ptr, ptr, fixed bin (35));
	dcl     mlsys_utils_$free_delivery_results entry (ptr, fixed bin (35));
	dcl     mlsys_utils_$print_delivery_results entry (ptr, bit (1) aligned, ptr, fixed bin (35));
	dcl     mlsys_utils_$print_address_list_field entry (char (*) var, ptr, fixed bin, ptr, fixed bin (35));
	dcl     ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_file_msgs_$single_msg entry (ptr, char (32) var, bit (1) aligned);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_send_msg_$ssu_exit entry ();
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_value_$get	 entry (char (*), char (*) var, fixed bin (35));
	dcl     xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35));

/* BUILTINS */
	dcl     (addr, null)	 builtin;

%page;
/* INCLUDE FILES */

%include xmail_data;
%page;
%include mlsys_deliver_info;
%page;
%include xmail_responses;
%page;
%include xmail_send_mail;
%page;
%include window_dcls;

/* BEGIN */

	recipients_info_ptr, sci_ptr = null ();
	send_area_ptr = get_system_free_area_ ();
	delivery_results_need_cleanup = "0"b;
	xmail_data.flags.cleanup_signalled = "0"b;

/* See if a message exists */

	if send_mail_info.msg_exists = "0"b
	then do;
	     call ioa_ ("There is no message to send.");
	     goto EXIT;
	end;

/* Set up conditions */

	on condition (cleanup) call CLEAN_UP;
	on condition (quit)
	     begin;
	          on condition (reissue_query) begin;
		     call window_$clear_window (iox_$user_output, (0));
		     goto RETRY (opt);
		     end;
	          xmail_data.cleanup_signalled = "1"b;
		if xmail_window_manager_$quit_handler ()
		then do;
		     call window_$clear_window (iox_$user_output, code);
		     if code ^= 0 then do;
			call xmail_error_$no_print (code, NAME, CONTINUE,
			     "Internal error trying to clear user_output");
			call xmail_window_manager_$reconnect ();
		     end;
		     call ioa_ ("Sending message terminated.");
		     call CLEAN_UP;
		     goto EXIT;
		end;
	     end;

/* See if there is a "bcc" or "cc" list */

	if send_mail_info.bcc_list_ptr ^= null ()
	then if send_mail_info.cc_list_ptr ^= null ()
	     then recipients_info_n_lists = 3;
	     else recipients_info_n_lists = 2;
	else if send_mail_info.cc_list_ptr ^= null ()
	then recipients_info_n_lists = 2;
	else recipients_info_n_lists = 1;

	alloc recipients_info in (send_area) set (recipients_info_ptr);

/* Add for bcc */

	if send_mail_info.bcc_list_ptr ^= null ()
	then if send_mail_info.cc_list_ptr ^= null ()
	     then do;
		recipients_info.lists (3).address_list_ptr = send_mail_info.bcc_list_ptr;
		recipients_info.lists (2).address_list_ptr = send_mail_info.cc_list_ptr;
	     end;
	     else recipients_info.lists (2).address_list_ptr = send_mail_info.bcc_list_ptr;
	else if send_mail_info.cc_list_ptr ^= null ()
	then recipients_info.lists (2).address_list_ptr = send_mail_info.cc_list_ptr;

	recipients_info.lists (1).address_list_ptr = send_mail_info.to_list_ptr;
	recipients_info.lists (*).recipients_result_list_ptr = null ();

	recipients_info.version = RECIPIENTS_INFO_VERSION_2;
	recipients_info.area_ptr = get_system_free_area_ ();
	auto_deliver_options.version = DELIVER_OPTIONS_VERSION_2;
	auto_deliver_options.delivery_mode = ORDINARY_DELIVERY;
	auto_deliver_options.queueing_mode = ALWAYS_QUEUE_FOREIGN;
	auto_deliver_options.queued_notification_mode = NOTIFY_ON_ERROR;
	auto_deliver_options.flags.abort = "1"b;
	auto_deliver_options.flags.send_if_empty = "0"b;
	auto_deliver_options.flags.recipient_notification = "1"b;

	call xmail_value_$get_with_default (ACKNOWLEDGE, (NO), acknowledge, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG,
		"^/Unable to get a value for ""^a"" in the xmail value segment.  Using the default value instead.", ACKNOWLEDGE);

	if acknowledge = NO
	then auto_deliver_options.flags.acknowledge = "0"b;
	else if acknowledge = ASK
	then do;
RETRY (1):		
	     opt = 1;
	     call xmail_get_str_$yes_no ("Do you want this message acknowledged? ", yes_sw);
	     if yes_sw then auto_deliver_options.flags.acknowledge = "1"b;
	     else auto_deliver_options.flags.acknowledge = "0"b;
	end;
	else if acknowledge = YES
	then auto_deliver_options.flags.acknowledge = "1"b;
	else do;
	     call xmail_error_$code_first (error_table_$bad_segment, NAME, LOG,
		"^/An invalid value for ""^a"" was found in the xmail value segment. Using the default value instead.", ACKNOWLEDGE);
	     auto_deliver_options.flags.acknowledge = "1"b;
	end;

	auto_deliver_options.flags.queue_mailing_lists = "0"b;
	auto_deliver_options.flags.mbz = "0"b;

	call mail_system_$deliver_message (send_mail_info.new_msg_ptr, recipients_info_ptr, addr (auto_deliver_options), code);
	delivery_results_need_cleanup = "1"b;
	if code ^= 0 then do;
	     send_mail_info.msg_exists = "1"b;
	     if code = mlsys_et_$no_a_permission then call xmail_error_$no_code (code, NAME, CONTINUE, "You do not have permission to send message to at least one of the recipients.");

	     if recipients_info.n_failed_recipients > 0
	     then do;
		call ioa_ ("Message could not be sent.");
		call ssu_$standalone_invocation (sci_ptr, "", "", null (), xmail_send_msg_$ssu_exit, code1);
		if code1 = 0 then call mlsys_utils_$print_delivery_results (sci_ptr, ERRORS_ONLY, recipients_info_ptr, code1);
		else call xmail_error_$no_code (code1, NAME, LOG, "The reason cannot be printed due to an internal programming error");
		call ssu_$destroy_invocation (sci_ptr);
		call xmail_error_$code_first (code, NAME, QUIT);
	     end;
	     call xmail_error_$code_first (code, NAME, QUIT, ERROR_MESSAGE);
	end;

/* Report that the messge was sent. */

	call ioa_ ("Message sent: ");
	call mlsys_utils_$print_address_list_field ("To", to_list_ptr, USE_SCREEN_WIDTH, null, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""To:"" recipient(s).");

	if cc_list_ptr ^= null
	then do;
	     call mlsys_utils_$print_address_list_field ("cc", cc_list_ptr, USE_SCREEN_WIDTH, null, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""cc:"" recipient(s).");
	end;
	else call ioa_ ("cc:  <None>");

/* Add for bcc */

	if bcc_list_ptr ^= null
	then do;
	     call mlsys_utils_$print_address_list_field ("bcc", bcc_list_ptr, USE_SCREEN_WIDTH, null, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""bcc:"" recipient(s).");
	end;
	else call ioa_ ("bcc:  <None>");

/* Is this message to be saved? */

	call xmail_value_$get (SAVE_MAILBOX, save_file, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG,
		"^/Unable to get a value for ""^a"" in the xmail value segment.  Using the default value instead.", SAVE_MAILBOX);

	call xmail_value_$get (SAVE_MESSAGE, save_message, code);
	if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG,
		"^/Unable to get a value for ""^a"" in the xmail value segment.  Using the default value instead.", SAVE_MESSAGE);

	if save_message = YES
	then do;
	     if save_file = ASK
	     then call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, "outgoing", ALLOW_SELECTION);
	     else call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, minus_suffix ((save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
	end;

	else if save_message = ASK
	then do;
RETRY (2):		
               opt = 2;
	     call xmail_get_str_$yes_no ("Do you wish to save a copy of this message? ", yes_sw);
	     if yes_sw then do;
		if save_file = ASK
		then call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, "outgoing", ALLOW_SELECTION);
		else call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, minus_suffix ((save_file), (MAILFILE_SUFFIX)), NO_SELECTION);
	     end;
	end;

	else if save_message ^= NO
	then call xmail_error_$code_first (error_table_$bad_segment, NAME, "q",
		"^/An invalid value for ""^a"" was found in the xmail value segment.", SAVE_MESSAGE);

	call CLEAN_UP;
EXIT:	return;

/* ENTRY POINTS */

ssu_exit: entry;

/* This entry doesn't do anything but it is called by ssu_$print_message */
/* which is called by mlsys_utils_$print_delivery_results.               */

	return;

/* INTERNAL PROCEDURES */

minus_suffix: proc (name, suffix) returns (char (*) var);

/* PARAMETERS */

	dcl     name		 char (*);
	dcl     suffix		 char (*);

/* AUTOMATIC */

	dcl     reverse_name	 char (length (name)) var;
	dcl     reverse_suffix	 char (length (suffix)) var;

/* BUILTINS */

	dcl     (after, index, length, reverse, rtrim) builtin;

	reverse_name = reverse (rtrim (name));
	reverse_suffix = reverse (rtrim (suffix));

	if index (reverse_name, reverse_suffix || ".") ^= 1
	then return (name);
	else return (reverse (after (reverse_name, reverse_suffix || ".")));

     end minus_suffix;

CLEAN_UP: proc ();

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

	if recipients_info_ptr ^= null ()
	then do;
	     if delivery_results_need_cleanup then do;
		call mlsys_utils_$free_delivery_results (recipients_info_ptr, code1);
		if code1 ^= 0 then call xmail_error_$no_print (code1, NAME, CONTINUE, "While cleaning up delivery results.");
	     end;
	     free recipients_info in (send_area);
	     recipients_info_ptr = null ();
	end;

	return;
     end CLEAN_UP;

     end xmail_send_msg_;




		    xmail_send_stored_msg_.pl1      09/02/88  0759.6r w 09/02/88  0745.8      105678



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



/****^  HISTORY COMMENTS:
  1) change(87-12-10,Blair), approve(87-12-10,MCR7818),
     audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013):
     Add capability to update a deferred message to include a reply-to field.
                                                   END HISTORY COMMENTS */


xmail_send_stored_msg_: proc ();

/* BEGIN DESCRIPTION

History:          Author unknown 

   83-07-21  DJ Schimke: Declared addr, codeptr, divide, null,  and rtrim 
   builtins. Removed unreferenced char_count, emacs_data_$status_code, 
   program_interrupt.

   83-10-15  DJ Schimke: Removed useless cleanup handler and performed other
   general code restructuring suggested by audit.

   83-10-26 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a 
   call to xmail_window_manager_$quit_handler so the quit condition handler
   can special-case the reconnect condition which should NOT interrupt 
   processing after the quit. phx 13227 This entry also prompts when not at
   a reconnect condition so that unintentionally hitting the BREAK won't 
   throw away any pending work. phx 13018

   83-11-01 DJ Schimke: Changed calling sequence of xmail_select_file_.

   84-09-24 JG Backs: Added code before and after the call to emacs_ to test
   if menus should be removed before editing (personalization option Remove
   Menus While Editing).  If option is in effect, calls to new entrypoints,
   $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also
   added test in quit handler to make sure restore menus is done if quit in
   editor.

   84-11-08 JG Backs: Changed the call and declaration statement of
   xmail_process_user_msg_ to eliminate the parameter which was not needed
   or used, and was eliminated from that module.  Audit change.

END DESCRIPTION
*/

/* AUTOMATIC */

	dcl     bit_count		 fixed bin (24);
          dcl     buffer_used            fixed bin;
	dcl     code		 fixed bin (35);
	dcl     flavor		 char (32);
          dcl     format_reply           char (32);
          dcl     format_reply_length    fixed bin;
          dcl     length_first_part      fixed bin;
          dcl     message_num            fixed bin;
	dcl     no_chars		 fixed bin (21);
	dcl     restore_menu_needed	 bit (1) aligned;	/* if remove menu */
	dcl     status		 fixed bin (35);
	dcl     store_dir		 char (168);
	dcl     store_file		 char (32) var;
	dcl     stored_msg_ptr	 ptr;
	dcl     type		 fixed bin (2);
	dcl     unused_bit		 bit (1) aligned;
	dcl     unused_bit2		 bit (1) aligned;
          dcl     user_name              char (22);

	dcl     1 auto_parse_text_options like parse_text_options;

/* INTERNAL STATIC */

	dcl     ext_dir		 char (168) int static;
	dcl     ext_file		 char (32) int static;
	dcl     ext_pname		 char (168) int static;
	dcl     ext_ptr		 ptr init (null) int static;

/* CONSTANTS */

	dcl     ALLOW_OLD		 bit (1) aligned options (constant) init ("1"b) int static;
          dcl     BITS_PER_BYTE          fixed bin (4) aligned options (constant) init (9) int static;
	dcl     DONT_ALLOW_NEW	 bit (1) aligned options (constant) init ("0"b) int static;
	dcl     EMACS_EXT		 char (21) options (constant) init ("xmail_emacs_ext_main_") int static;
	dcl     ENTRY_NAME		 entry variable init (xmail_send_stored_msg_);
	dcl     ERROR_MESSAGE	 char (66) static options (constant) init ("Sorry, due to an internal error the stored message cannot be sent.");
	dcl     LOG		 char (1) static options (constant) init ("l");
	dcl     MAKE_SEG_RW		 fixed bin (5) static options (constant) init (01010b);
	dcl     NAME		 char (22) static options (constant) init ("xmail_send_stored_msg_");
	dcl     NL		 char (1) aligned static options (constant) init ("
");
	dcl     STOP		 char (1) static options (constant) init ("q");
	dcl     TERM_FILE_BC	 bit (2) static options (constant) init ("01"b);
	dcl     WHITE_SPACE_COMMA	 char (6) aligned static options (constant) init ("
	  ,");					/* HT VT NL <space> comma */
/* EXTERNAL STATIC */

	dcl     iox_$user_output	 ptr external static;
	dcl     (error_table_$namedup, error_table_$segknown) fixed bin (35) ext;

/* ENTRIES */

	dcl     emacs_		 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     get_pdir_		 entry () returns (char (168));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$set_bc_seg	 entry (ptr, fixed bin (24), fixed bin (35));
	dcl     hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     mlsys_utils_$parse_address_list_text entry options(variable);
	dcl     mlsys_utils_$format_text_field entry options(variable);
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));
	dcl     user_info_ entry (char(*));
	dcl     xmail_error_$no_code	 entry options (variable);
	dcl     xmail_process_user_msg_ entry ();	/* no parameter */
	dcl     xmail_redisplay_$menu	 entry ();
	dcl     xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned,
				 char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35));
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_window_manager_$restore_menu entry ();
	dcl     xmail_window_manager_$suppress_menu entry ();

/* CONDITIONS */

	dcl     quit		 condition;

/* BASED */

	dcl     stored_string	 char (no_chars) based (stored_msg_ptr);
	dcl     emacs_seg_string	 char (no_chars) based (send_mail_info.emacs_seg_ptr);


/* BUILTINS */

	dcl     (addr, after, before, codeptr, divide, index, length, null, rtrim, substr) builtin;

/* INCLUDE FILES */

%include xmail_send_mail;
%page;
%include xmail_data;
%page;
%include mlsys_parse_txt_options;
%page;
%include window_dcls;
%page;
%include mlsys_address_list;
%page;
%include mlsys_field_names;

/* BEGIN */

	restore_menu_needed = "0"b;
	on condition (quit)
	     begin;
		if xmail_window_manager_$quit_handler ()
		then do;
		     if restore_menu_needed
		     then do;
			call xmail_window_manager_$restore_menu;
			call xmail_redisplay_$menu;
		     end;
		     call window_$clear_window (iox_$user_output, (0)); /* ignore code */
		     call ioa_ ("Sending ""deferred message"" terminated.");
		     go to EXIT;
		end;
	     end;

	call xmail_select_file_$caller_msg ("deferred message", "defer", "", ALLOW_OLD, DONT_ALLOW_NEW, store_dir, store_file, "Enter name of ""deferred message"" (or ?? for list)", unused_bit, unused_bit2, code);
	if code ^= 0 then go to EXIT;

	call hcs_$make_seg (store_dir, rtrim (store_file) || ".defer", "", MAKE_SEG_RW, stored_msg_ptr, code);

	call hcs_$status_mins (stored_msg_ptr, type, bit_count, code);
	if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);
/* Set up to add a Reply_To field if none exists */

	auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1;
	auto_parse_text_options.area_ptr = null();
	auto_parse_text_options.flags.list_errors = "0"b;
	auto_parse_text_options.flags.validate_addresses = "0"b;
	auto_parse_text_options.flags.include_invalid_addresses = "0"b;
	auto_parse_text_options.flags.mbz = "0"b;

	call user_info_ (user_name); /* we might need this */

/* Get number of chars in seg */

	if bit_count = 0
	then do;
	     call ioa_ ("The specified ""deferred message"" is empty.");
	     go to EXIT;
	end;
	no_chars = divide (bit_count, 9, 17, 0);
	reply_to_list_ptr = null;
	if index(before(stored_string,NL || "To:"), "Reply-To:") > 0 then do;
	     call mlsys_utils_$parse_address_list_text (rtrim (after (before (stored_string,
	     "To:"), "Reply-To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options),
	     ADDRESS_LIST_VERSION_2, reply_to_list_ptr, parse_text_error_list_ptr, code);
	     if code ^= 0 then
		call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
	     end;
	else do;
	     format_reply = "";
	     format_reply_length = length ("Reply-To:  ") + length(user_name);
	     call mlsys_utils_$format_text_field (REPLY_TO_FIELDNAME, rtrim(user_name), ("0"b),
		format_reply_length, addr(format_reply), format_reply_length, buffer_used, code);
	     if code ^= 0 then
		call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num);
	     no_chars = format_reply_length + length(NL) + no_chars;
	     bit_count = no_chars * BITS_PER_BYTE;
	     length_first_part = index(stored_string,NL);
	     stored_string = substr(stored_string,1,length_first_part) ||
		rtrim(format_reply) || NL || substr(stored_string,length_first_part+1, no_chars - (length_first_part + length(NL) + format_reply_length));
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);
	end;
	call hcs_$make_seg ("", xmail_data.actee.person || "_sm", "", MAKE_SEG_RW, send_mail_info.emacs_seg_ptr, code);
	if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segknown then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);

	call terminate_file_ (send_mail_info.emacs_seg_ptr, bit_count, TERM_FILE_BC, code);
	emacs_seg_string = stored_string;
	if ext_ptr = null ()
	then do;
	     call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "", ext_ptr, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);
	     call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);
	     ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT;
	end;


	flavor = "edit";
	call ioa_ ("...Please wait for editor...");

/* Check personalization option to remove and restore menus while editing */

	if xmail_data.remove_menus
	then do;
	     call xmail_window_manager_$suppress_menu ();
	     restore_menu_needed = "1"b;
	end;

	call emacs_ (iox_$user_output, rtrim (get_pdir_ ()) || ">" || rtrim (actee.person) || "_sm", ext_pname, addr (flavor), status);

	if restore_menu_needed
	then do;
	     call xmail_window_manager_$restore_menu ();
	     call xmail_redisplay_$menu;
	     restore_menu_needed = "0"b;
	end;

	if status = 1
	then do;
	     call hcs_$status_mins (send_mail_info.emacs_seg_ptr, 1, bit_count, code);
	     if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE);
	     no_chars = divide (bit_count, 9, 17, 0);
	     stored_string = emacs_seg_string;
	     call hcs_$set_bc_seg (stored_msg_ptr, bit_count, code);
	     call ioa_ ("Deferred message ""^a"" saved.", store_file);
	     go to EXIT;
	end;
	if status ^= 0
	then do;
	     call xmail_window_manager_$reconnect ();
	     call ioa_ ("Sending ""deferred message"" terminated.");
	     go to EXIT;
	end;
	else call xmail_process_user_msg_ ();		/* no parameter */

EXIT:	return;


     end xmail_send_stored_msg_;






		    xmail_sw_.pl1                   09/02/88  0759.6r w 09/02/88  0745.6       70515



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



/****^  HISTORY COMMENTS:
  1) change(86-02-27,Blair), approve(86-02-27,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     85-03-08 JGBacks: Deleted two unused entrypoints $update_actee and
     $update_date, plus variables, external entries, and the clock builtin
     used by them.  Format statement was also removed because it was wrong.
                                                   END HISTORY COMMENTS */


xmail_sw_:
initialize: proc ();

/* BEGIN DESCRIPTION 
history:

  Written before June 81 by S. Krupp 

  Modified  June 81 by P. Kyzivat during extensive changes to xmail 

  83-07-27 Dave Schimke: Delete dcls for unreferenced items: code, 
  convert_date_to_binary_, timer_manager_$alarm_call, and
  timer_manager_$reset_alarm_call.

  83-10-15 DJ Schimke: Cleanup the code to satisfy audit.

END DESCRIPTION
*/

/* ENTRIES */

	dcl     window_display_	 entry (ptr, (*) char (*), fixed bin (35));
	dcl     xmail_error_$no_print	 entry () options (variable);

/* BASED */

	dcl     display_window	 (xmail_windows.status.height) char (window_image_width) based (window_image_ptr);
	dcl     window_image	 (3) char (window_image_width) based (window_image_ptr);

/* BUILTINS */

	dcl     (addr, copy, divide, length, ltrim, min, string, rtrim) builtin;

/* CONSTANTS */

	dcl     LOG		 char (1) int static options (constant) init ("l");
	dcl     NAME		 char (9) int static options (constant) init ("xmail_sw_");


/* INTERNAL STATIC */

	dcl     file_field_len	 fixed bin int static;
	dcl     file_info_field_len	 fixed bin int static;
	dcl     pos_field_len	 fixed bin int static;
	dcl     usage_field_len	 fixed bin int static;
	dcl     window_image_ptr	 ptr int static;
	dcl     window_image_width	 fixed bin int static;
	dcl     static_window_image	 (3) char (132) unal static;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry is called only once per xmail invocation to initialize the status window. */
/* It sets all the internal static variables used in the other entry points.	        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	static_window_image (*) = "";
	window_image_ptr = addr (static_window_image);
	window_image_width = min (length (static_window_image (1)),
	     xmail_windows.status.width);
	string (window_image) = "";

	file_field_len, file_info_field_len = 0;
	usage_field_len = window_image_width - (file_field_len + file_info_field_len);
	pos_field_len = window_image_width;

	return;

update_file: entry (str);

	dcl     str		 char (*);

	if str ^= "" then file_field_len = 20;

	call UPDATE (1, 1, file_field_len, str);	/* file name goes on line 1, col 1 */

	if str = "" then file_field_len = 0;

	return;

update_file_info: entry (str);

	if str ^= "" then file_info_field_len = 20;

	begin;

	     dcl	   field		      char (file_info_field_len);
	     dcl	   trimmed_value	      char (length (str)) var;
	     dcl	   trimmed_len	      fixed bin;
	     dcl	   starting_col	      fixed bin;

	     starting_col = window_image_width - file_info_field_len + 1;

	     trimmed_value = ltrim (rtrim (str));
	     trimmed_len = length (trimmed_value);

	     if trimmed_len < file_info_field_len
	     then do;
		     call RIGHT_JUSTIFY ((trimmed_value), field);
		     call UPDATE (1, starting_col, file_info_field_len, field);
		end;
	     else call UPDATE (1, starting_col, file_info_field_len, str);

	     if str = "" then file_info_field_len = 0;

	     return;

	end;					/* begin */

update_position: entry (str);

	begin;

	     dcl	   field		      char (pos_field_len);
	     dcl	   trimmed_value	      char (length (str)) var;
	     dcl	   trimmed_len	      fixed bin;

	     trimmed_value = ltrim (rtrim (str));
	     trimmed_len = length (trimmed_value);

	     if trimmed_len < pos_field_len
	     then do;
		     call CENTER ((trimmed_value), field);
		     call UPDATE (2, 1, pos_field_len, field);
		end;
	     else call UPDATE (2, 1, pos_field_len, str);

	     return;

	end;					/* begin */

update_usage: entry (str);

	dcl     used_cols		 fixed bin;
	dcl     rused_cols		 fixed bin;

	if file_field_len ^= 0 & file_info_field_len ^= 0
	then used_cols = file_field_len + file_info_field_len;
	else used_cols = 2 * (file_field_len + file_info_field_len);
	rused_cols = divide (used_cols, 2, 17, 0);

	usage_field_len = window_image_width - used_cols;

	begin;

	     dcl	   field		      char (usage_field_len);
	     dcl	   trimmed_value	      char (length (str)) var;
	     dcl	   trimmed_len	      fixed bin;
	     dcl	   starting_col	      fixed bin;

	     starting_col = window_image_width - (rused_cols + usage_field_len) + 1;

	     trimmed_value = ltrim (rtrim (str));
	     trimmed_len = length (trimmed_value);

	     if trimmed_len < usage_field_len
	     then do;
		     call CENTER ((trimmed_value), field);
		     call UPDATE (1, starting_col, usage_field_len, field);
		end;
	     else call UPDATE (1, starting_col, usage_field_len, str);

	     return;

	end;					/* begin */

redisplay: entry ();

	dcl     code		 fixed bin (35);

	call window_display_ (xmail_windows.status.iocb, display_window, code);
	if code ^= 0 then call xmail_error_$no_print (code, NAME, LOG);
	return;

CENTER: proc (P_str, P_field);

	dcl     (P_str, P_field)	 char (*);
	dcl     (field_len, str_len, n_pad, l_pad) fixed bin;

	field_len = length (P_field);
	str_len = length (P_str);

	n_pad = field_len - str_len;
	l_pad = divide (n_pad, 2, 17, 0);
	P_field = copy (" ", l_pad) || P_str;

     end CENTER;

RIGHT_JUSTIFY: proc (P_str, P_field);

	dcl     (P_str, P_field)	 char (*);
	dcl     (field_len, str_len, n_pad) fixed bin;

	field_len = length (P_field);
	str_len = length (P_str);

	n_pad = field_len - str_len;

	P_field = copy (" ", n_pad) || P_str;


     end RIGHT_JUSTIFY;

UPDATE: proc (line, col, len, new_value);

	dcl     (line, col, len)	 fixed bin,
	        new_value		 char (*);
	dcl     short_new_value	 defined (new_value) char (len),
	        trunc_new_value	 defined (new_value)
				 char (len - length (TRUNCATION_STRING));
	dcl     TRUNCATION_STRING	 init (" ...") char (4) static options (constant);
	dcl     (length, rtrim)	 builtin;

	if len >= length (new_value)
	then call RAW_UPDATE (line, col, len, new_value);
	else if len <= length (TRUNCATION_STRING) | len >= length (rtrim (new_value))
	then call RAW_UPDATE (line, col, len, short_new_value);
	else do;
		call RAW_UPDATE (line, col,
		     length (trunc_new_value), trunc_new_value);
		call RAW_UPDATE (line,
		     col + length (trunc_new_value),
		     length (TRUNCATION_STRING), TRUNCATION_STRING);
	     end;


     end UPDATE;

RAW_UPDATE: proc (line, col, len, new_value);

	dcl     (line, col, len)	 fixed bin,
	        new_value		 char (*);

	dcl     field_p		 ptr,
	        field_l		 fixed bin,
	        field		 char (field_l) based (field_p);


	dcl     (addr, char, substr)	 builtin;

	field_p = addr (substr (window_image (line), col));
	field_l = len;
	if char (new_value, len) ^= field
	then field = new_value;

     end RAW_UPDATE;

%include xmail_data;
%page;
%include xmail_windows;
%page;
%include window_dcls;

     end xmail_sw_;




		    xmail_undelete_msgs_.pl1        09/02/88  0759.6r w 09/02/88  0745.5       32256



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




/****^  HISTORY COMMENTS:
  1) change(86-02-26,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     On a cleanup exit ( user hits break when in Multics mode) we come here to
     undelete any messages marked for deletion, but we don't want to put out
     the message to the user.
                                                   END HISTORY COMMENTS */


xmail_undelete_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_pos_line, P_flavor);

/* Author unknown

   83-07-27  DJ Schimke: Modified to use new mail_system calls and version 2
   mailboxes.
*/

/* Parameter */

	dcl     P_mailbox_ptr	 ptr;
	dcl     P_curr_msgsp	 ptr;
	dcl     P_pos_line		 char (*);
	dcl     P_flavor		 char (*);

/* Automatic */

	dcl     add_more_msg	 bit (1) aligned;
	dcl     code		 fixed bin (35);
	dcl     deleted_msgsp	 ptr;
	dcl     i			 fixed bin;
	dcl     message_num		 fixed bin;
	dcl     message_ptr		 ptr;

/* Builtin */

	dcl     (length, maxlength, null, rtrim) builtin;

/* Entries */

	dcl     ioa_		 entry () options (variable);
	dcl     mail_system_$read_message entry (ptr, fixed bin, fixed bin (35));
	dcl     mail_system_$unmark_message_for_deletion entry (ptr, fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_select_msgs_$deleted entry (ptr, ptr, char (*));
	dcl     xmail_select_msgs_$replace_curr entry (ptr, ptr, char (*));

/* Constant */

	dcl     ME_CHAR		 char (20) init ("xmail_undelete_msgs_") int static options (constant);
	dcl     MORE_MSG		 char (9) init (" MORE ...") int static options (constant);

	mailbox_ptr = P_mailbox_ptr;


	call xmail_select_msgs_$deleted (mailbox_ptr, deleted_msgsp, P_flavor);

	if deleted_msgsp = null then goto EXIT;
	do i = 1 to deleted_msgsp -> curr_msgs.count;
	     message_num = deleted_msgsp -> curr_msgs.numbers (i);
	     if mailbox.messages (message_num).message_ptr = null
	     then do;
		call mail_system_$read_message (mailbox_ptr, message_num, code);
		if code ^= 0
		then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", message_num);
	     end;
	     message_ptr = mailbox.messages (message_num).message_ptr;
	     call mail_system_$unmark_message_for_deletion (message_ptr, code);
	     if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to retrieve message ^d. This is an internal programming error.", message_num);
	end;

	call xmail_select_msgs_$replace_curr (P_curr_msgsp, deleted_msgsp, P_pos_line);



	if length (rtrim (P_pos_line)) > maxlength (P_pos_line) - length (MORE_MSG) then add_more_msg = "1"b;
	else add_more_msg = "0"b;
	if ^xmail_data.cleanup_signalled
	then call ioa_ ("Message^[s^;^] ^a ^[^a^] retrieved.", (deleted_msgsp -> curr_msgs.count > 1), rtrim (P_pos_line), add_more_msg, MORE_MSG);

EXIT:

	return;

%page;
%include xmail_curr_msg_info;
%page;
%include mlsys_mailbox;
%page;
%include xmail_prompts;
%page;
%include xmail_data;

     end xmail_undelete_msgs_;




		    xmail_update_mlist_.pl1         09/02/88  0759.6r w 09/02/88  0745.4       44343



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




/****^  HISTORY COMMENTS:
  1) change(86-04-16,Blair), approve(86-04-16,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Remove unreferenced constants.
                                                   END HISTORY COMMENTS */


xmail_update_mlist_: proc (P_dir, P_file);

/* BEGIN DESCRIPTION

History:       Author unknown

   83-10-26 DJ Schimke: Added quit condition handler with a call to
   xmail_window_manager_$quit_handler to special-case the reconnect condition 
   which should NOT interrupt processing after the quit. phx 13227  This entry
   also prompts when not at a reconnect condition so that unintentionally
   hitting the BREAK won't throw away any pending work. phx 13018

   84-09-24 JG Backs: Added code before and after the call to emacs_ to test
   if menus should be removed before editing (personalization option Remove
   Menus While Editing).  If option is in effect, calls to new entrypoints,
   $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also
   added test in quit handler to make sure restore menus is done if quit in
   editor.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     (P_dir, P_file)	 char (*);

/* AUTOMATIC */

	dcl     code		 fixed bin (35);
	dcl     restore_menu_needed	 bit (1) aligned;	/* if remove menu */
	dcl     seg_pname		 char (168);

/* BUILTINS */

	dcl     (codeptr, null, rtrim) builtin;

/* ENTRIES */

	dcl     com_err_$suppress_name entry () options (variable);
	dcl     emacs_		 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
	dcl     hcs_$make_ptr	 entry (ptr, char (*), char (*), ptr, fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     xmail_redisplay_$menu	 entry ();
	dcl     xmail_window_manager_$quit_handler entry () returns (bit (1) aligned);
	dcl     xmail_window_manager_$reconnect entry ();
	dcl     xmail_window_manager_$restore_menu entry ();
	dcl     xmail_window_manager_$suppress_menu entry ();

/* INTERNAL STATIC */

	dcl     ext_dir		 char (168) int static;
	dcl     ext_file		 char (32) int static;
	dcl     ext_pname		 char (168) int static;
	dcl     ext_ptr		 ptr init (null) int static;

/* EXTERNAL STATIC */

	dcl     iox_$user_io	 ptr ext static;
	dcl     xmail_err_$int_prog_err fixed bin (35) ext static;

/* CONSTANTS */

	dcl     EXTENSION_ENAME	 char (22) init ("xmail_emacs_ext_mlist_") int static options (constant);
	dcl     ME_CHAR		 char (19) init ("xmail_update_mlist_") int static options (constant);
	dcl     ME_ENTRY		 entry variable init (xmail_update_mlist_);

/* CONDITIONS */

	dcl     (quit)		 condition;

/* INCLUDE FILES */

%include xmail_data;

/* BEGIN */

	restore_menu_needed = "0"b;
	if ext_ptr = null
	then do;
	     call hcs_$make_ptr (codeptr (ME_ENTRY), EXTENSION_ENAME, "", ext_ptr, code);
	     if code ^= 0 then call update_mlist_err (xmail_err_$int_prog_err, "Trying to locate extension.");
	     call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code);
	     if code ^= 0 then call update_mlist_err (xmail_err_$int_prog_err, "Trying to get extension pathname");
	     ext_pname = rtrim (ext_dir) || ">" || rtrim (EXTENSION_ENAME);
	end;

	on condition (quit)
	     begin;
		if xmail_window_manager_$quit_handler ()
		then do;
		     if restore_menu_needed
		     then do;
			call xmail_window_manager_$restore_menu;
			call xmail_redisplay_$menu;
		     end;
		     go to EXIT;
		end;
	     end;

	seg_pname = rtrim (P_dir) || ">" || rtrim (P_file);

	call ioa_ ("... Please wait for editor ...");

/* Check personalization option to remove and restore menus while editing */

	if xmail_data.remove_menus
	then do;
	     call xmail_window_manager_$suppress_menu ();
	     restore_menu_needed = "1"b;
	end;

	call emacs_ (iox_$user_io, seg_pname, ext_pname, null, code);

	if restore_menu_needed
	then do;
	     call xmail_window_manager_$restore_menu ();
	     call xmail_redisplay_$menu;
	     restore_menu_needed = "0"b;
	end;

	if code ^= 0 then call xmail_window_manager_$reconnect ();

EXIT:

	return;

%page;
/* INTERNAL PROCEDURES */

update_mlist_err: proc (P_code, P_str);

	dcl     P_code		 fixed bin (35);
	dcl     P_str		 char (*);

	call com_err_$suppress_name (P_code, ME_CHAR);
	go to EXIT;

     end update_mlist_err;

     end xmail_update_mlist_;







		    xmail_validate_.pl1             09/02/88  0759.6rew 09/02/88  0736.1       55008



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




/****^  HISTORY COMMENTS:
  1) change(88-06-29,Blair), approve(88-07-27,MCR7931),
     audit(88-08-30,RBarstad), install(88-09-02,MR12.2-1098):
     Call mail_system_$create_mailing_list_address to generate the address
     rather than generating it ourselves with the "{list ...}" construct. This
     will allow names with embedded blanks.
                                                   END HISTORY COMMENTS */


xmail_validate_: proc ();

/* Author unknown

   83-07-27 DJ Schimke: Modified to use new mail_system_ interfaces and 
   version 2 mailboxes.

   83-09-14 DJ Schimke: Modified the call to hcs_$status_minf so a link to a
   mailing list is considered a valid mailing list. TR12078
*/

/* Parameter */

	dcl     P_addr_str		 char (*);
	dcl     P_code		 fixed bin (35);
	dcl     P_curr_msgsp	 ptr;
	dcl     P_mailbox_ptr	 ptr;

/* Automatic */

	dcl     address_ptr		 ptr;
	dcl     addr_str		 char (200);
	dcl     bit_count		 fixed bin (24);
	dcl     code		 fixed bin (35);
	dcl     mailing_list	 bit (1) aligned;
	dcl     mlist_name		 char (32);
	dcl     type		 fixed bin (2);

/* Entries */

	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     mlsys_utils_$parse_address_text entry (char (*), ptr, fixed bin (35));
          dcl     mail_system_$create_mailing_list_address entry (char (*), char (*), char (*), char (*) varying, char (*) varying, ptr, fixed bin (35));
	dcl     mail_system_$free_address entry (ptr, fixed bin (35));
	dcl     mail_system_$validate_address entry entry (ptr, bit (1) aligned, fixed bin (35));

/* Constant */

	dcl     CHASE		 fixed bin (1) init (1) int static options (constant);
	dcl     MLIST_SUFFIX	 char (4) init (".mls") int static options (constant);
	dcl     SEG		 fixed bin (2) init (1) int static options (constant);
	dcl     VALIDATE_LIST	 bit (1) aligned init ("1"b) int static options (constant);

/* External Static */

	dcl     (error_table_$badcall,
	        error_table_$unimplemented_version,
	        error_table_$noaccess,
	        mlsys_et_$message_queued,
	        mlsys_et_$no_mailbox,
	        xmail_err_$bad_mailing_list,
	        xmail_err_$mailing_list) fixed bin (35) ext;

/* Builtin  */

	dcl     (ltrim, null, rtrim)	 builtin;

mbx: entry (P_mailbox_ptr, P_code);

	P_code = 0;

	if P_mailbox_ptr = null
	then do;
	     P_code = error_table_$badcall;
	     return;
	end;

	mailbox_ptr = P_mailbox_ptr;

	if mailbox.version ^= MAILBOX_VERSION_2
	then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	return;					/* mbx entry */

curr_msgs: entry (P_curr_msgsp, P_code);

	P_code = 0;

	if P_curr_msgsp = null
	then do;
	     P_code = error_table_$badcall;
	     return;
	end;

	curr_msgsp = P_curr_msgsp;

	if curr_msgs.version ^= MSG_STRUCT_VERSION_1
	then do;
	     P_code = error_table_$unimplemented_version;
	     return;
	end;

	return;					/* curr_msgs entry */

addr: entry (P_addr_str, P_code);

/* Important codes returned by this entry:


    0                                 --  P_addr_str is an address with
                                          good syntax and is deliverable
    xmail_err_$mailing_list           --  P_addr_str specifies a valid
                                          mailing list
    mlsys_et_$invalid_address_syntax  --  P_addr_str is an address with
                                          invalid syntax
    mlsys_et_$no_mailbox              --  P_addr_str is an address with
                                          good syntax, but is undeliverable
    mlsys_et_$no_a_permission         --  P_addr_str is an address with
                                          good syntax but, is undeliverable
    mlsys_et_$mte_not_found           --  P_addr_str is good syntax for a 
                                          mail_table address, but no such
                                          mail_table entry exists
  */

/* Is it a mailing list name? */

	mlist_name = ltrim (rtrim (P_addr_str)) || MLIST_SUFFIX;
	call hcs_$status_minf ((xmail_data.mail_dir), mlist_name, CHASE, type, bit_count, code);
	if code = 0 & type = SEG then do;
	     mailing_list = "1"b;
               call mail_system_$create_mailing_list_address ((xmail_data.mail_dir),
		mlist_name, "", "", "", address_ptr, code);
	     if code ^= 0 then do;
	         P_code = code;
	         goto EXIT;
	         end;
	end;
	else do;
	     mailing_list = "0"b;			/* if code ^= 0 ignore and assume it's not a mailing_list */
	     addr_str = P_addr_str;
	     call mlsys_utils_$parse_address_text (addr_str, address_ptr, code);
	     if code ^= 0
		then do;
		P_code = code;
		goto EXIT;
		end;
	end;

/* If the syntax is ok, is there a corresponding mailbox? */
/* For mailing_lists, are all addresses valid?            */

	call mail_system_$validate_address (address_ptr, VALIDATE_LIST, code);
	if code = 0 | code = mlsys_et_$message_queued
	then P_code = 0;
	else if code = error_table_$noaccess then P_code = mlsys_et_$no_mailbox;
	else P_code = code;

EXIT:	call mail_system_$free_address (address_ptr, (0));/* ignore error */

	if mailing_list then do;
	     if P_code = 0 then P_code = xmail_err_$mailing_list;
	     else P_code = xmail_err_$bad_mailing_list;
	end;
	return;					/* addr entry */

%page;
%include mlsys_mailbox;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_data;

     end xmail_validate_;




		    xmail_value_.pl1                09/02/88  0759.6r w 09/02/88  0745.2      115551



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



/****^  HISTORY COMMENTS:
  1) change(86-02-26,Blair), approve(86-02-26,MCR7358),
     audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062):
     Add new internal procedures to get the value segment ptr, validate the
     value returned by value_$get, and determine the default value for a
     particular name. There is a table of names of the values used by xmail and
     validate_name_and_index returns the index to tables of validation routines
     and default values.
     
     There is also a new entry point - get_no_validate.
  2) change(86-07-15,Blair), approve(86-07-15,MCR7447),
     audit(86-07-16,LJAdams), install(86-07-21,MR12.0-1100):
     Initiate the data_seg for RW when getting the pointer to it so as to avoid
     problems with differing ring-brackets.
  3) change(87-01-21,Blair), approve(87-02-05,MCR7618),
     audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025):
     Make entries in the default_value array and test_value array for the new
     value seg entry msgs_as_mail_yn.
                                                   END HISTORY COMMENTS */

/*
			xmail_value_

	This program provides an interface to the xmail value segment.
	Entries are provided to manipulate named values.  The actual
	management of the segment is performed via the value_$...
	utility subroutines for dealing with value segments.  The
	entries provided here provide primarily a subset of the
	capabilities provided by value_, the major difference being that
	the specification of the value segment itself is absent.

	The other major change is that arbitrary datatypes are not allowed.
	To ease the implementation, names are always char (*) and values
	are always char (*) varying.

	Additional functionality has been added in the form of a new
	entrypoint, get_with_default, which automatically returns a
	specified default value when the name is not defined.

	The following parameter names are common to the various entries:

	name:	   the name of the value to be referenced

	in_value:    a value supplied by the caller

	out_value:   a value returned to the caller

	test_value:  a value supplied by the caller for test purposes

	code	   a system status code as returned by value_

	**************************************************************

	The following entrypoints are defined:

	defined (name, code) returns (bit (1))
	delete (name, code)
	get (name, out_value, code)
	set (name, in_value, out_value, code)
	test_and_set (name, in_value, test_value, code)
	get_with_default (name, in_value, out_value, code)

	In set, out_value is the old value before it was changed.
	In get_with_default, in_value is the default, which is returned
	in out_value if no value is defined.
*/

/* Written 6/29/81 by Paul Kyzivat */
/* format: style1 */
%page;
xmail_value_: proc;

	dcl     name		 char (*) parameter,
	        in_value		 char (*) varying parameter,
	        out_value		 char (*) varying parameter,
	        test_value		 char (*) varying parameter,
	        code		 fixed bin (35);
          dcl     index                  fixed bin;
          dcl     (fixed, length, null, rtrim, search, verify)
                                         builtin;
	dcl     value_seg_ptr          ptr;
	dcl     PERMANENT		 init ("01"b) bit (36) aligned static options (constant);
	dcl     error_table_$oldnamerr fixed bin (35) ext static;
	dcl     value_$defined	 entry (ptr, bit (36) aligned, char (*), fixed bin (35)) returns (bit (1) aligned),
	        (
	        value_$delete,
	        value_$get,
	        value_$set,
	        value_$test_and_set
	        )			 entry options (variable);
          dcl xmail_rebuild_value_seg_ entry (ptr, fixed bin (35));	
%page;
defined: entry (name, code) returns (bit (1));
          call validate_value_seg (value_seg_ptr);
          call validate_name_and_index (name, index);
	return (value_$defined (value_seg_ptr , PERMANENT, name, code));

delete: entry (name, code);
          call validate_value_seg (value_seg_ptr);
          call validate_name_and_index (name, index);
	call value_$delete (value_seg_ptr, PERMANENT, name, code);
	return;

get: entry (name, out_value, code);
	call validate_value_seg (value_seg_ptr);
          call validate_name_and_index (name, index);
	if value_seg_ptr ^= null
	then call value_$get (value_seg_ptr, PERMANENT, name, out_value, code);
	if code = error_table_$oldnamerr & (index > 14 & index < 21) then; 
	else if code ^= 0 | value_seg_ptr = null
	then do;
		call xmail_rebuild_value_seg_ (value_seg_ptr, code);
		call get_default_value (index, out_value);
	     end;	     
	else do;
	     call validate_returned_value (index, out_value, code);
	     if code ^= 0
	     then do;
		call xmail_rebuild_value_seg_ (value_seg_ptr, code);
		call get_default_value (index, out_value);
		end;
	     end;
	return;

get_no_validate: entry (name, out_value, code);
	call validate_value_seg (value_seg_ptr);
          call validate_name_and_index (name, index);
	if value_seg_ptr ^= null
	then call value_$get (value_seg_ptr, PERMANENT, name, out_value, code);
	if code = error_table_$oldnamerr then; 
	else if code ^= 0 | value_seg_ptr = null
	then do;
	     call xmail_rebuild_value_seg_ (value_seg_ptr, code);
	     call get_default_value (index, out_value);
	     end;	     
	return;

set: entry (name, in_value, out_value, code);
          call validate_value_seg (value_seg_ptr);
	call validate_name_and_index (name, index);
	if value_seg_ptr = null
	     then call xmail_rebuild_value_seg_ (value_seg_ptr, code);
	call value_$set (value_seg_ptr, PERMANENT, name, in_value, out_value, code);
	if code ^= 0 then do;
	     call xmail_rebuild_value_seg_ (value_seg_ptr, code);
	     call get_default_value (index, out_value);
	     end;
	return;



test_and_set: entry (name, in_value, test_value, code);
	call validate_value_seg (value_seg_ptr);
          call validate_name_and_index (name, index);

          call value_$test_and_set (value_seg_ptr, PERMANENT, name, in_value, out_value, code);
	if code ^= 0 then do;
	     call xmail_rebuild_value_seg_ (value_seg_ptr, code);
	     call get_default_value (index, out_value);
	     end;
	return;

get_with_default: entry (name, in_value, out_value, code);
	call validate_value_seg (value_seg_ptr);
	call validate_name_and_index (name, index);
	if value_seg_ptr ^= null
	then call value_$get (value_seg_ptr, PERMANENT, name, out_value, code);
	if (code = error_table_$oldnamerr) then do;
		out_value = in_value;
		code = 0;
	     end;
	else if code ^= 0 then do;
	     call xmail_rebuild_value_seg_ (value_seg_ptr, code);
	     call get_default_value (index, out_value);
	     end;
	return;
%page;
validate_value_seg:  proc (vvs_value_seg_ptr);
		 
	dcl initiate_file_    entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
	dcl bc                fixed bin (24);
	dcl vvs_code              fixed bin (35);
          dcl vvs_value_seg_ptr ptr;
          dcl VALUE_SEG_NAME    init ("xmail_data.value") char (32) var int static options (constant);

/* Get the pointer to the value seg just before we use it */

	vvs_value_seg_ptr = null;
	call initiate_file_ (rtrim(xmail_data.value_seg_pathname), (VALUE_SEG_NAME), RW_ACCESS, vvs_value_seg_ptr, bc, vvs_code);
	return;
     end validate_value_seg;

validate_name_and_index: proc (vn_name, vn_index);
		     	 
	dcl VN_NAME_ARRAY dim (1:21) char (25) int static options (constant) init
              ("acknowledge_yn           ",
               "always_escape_keys_yn    ",
               "confirm_print_yn         ",
               "file_original_yn         ",
               "include_original_yn      ",
               "original_up_window_yn    ",
               "msgs_as_mail_yn          ",
               "interactive_msgs_yn      ",
	     "lists_as_menus_yn        ",
               "multics_mode_yn          ",
               "remove_menus_yn          ",
               "save_mailfile            ",
               "save_message_yn          ",
               "version                  ",
               "dprint_heading           ",
               "dprint_destination       ",
               "dprint_request_type      ",
               "dprint_copies            ",
               "dprint_left_margin       ",
               "dprint_notify            ",
               "lifetime_first_invocation");
          dcl vn_index        fixed bin;
          dcl vn_name         char (*);
/* Now get the index to the table of names */

          do vn_index = 1 to 21 while (VN_NAME_ARRAY (vn_index) ^= rtrim(vn_name));
	     end;
	return;
     end validate_name_and_index;
%page;
validate_returned_value: proc (vrv_index, vrv_out_value, vrv_code);

          dcl vrv_code         fixed bin (35);
          dcl vrv_index        fixed bin;
          dcl vrv_out_value    char (*) var;
          dcl generic_type     char (32);
          dcl non_number       fixed bin;
          dcl TEST_VALUE_ARRAY dim (1:21) fixed bin int static options (constant) init
              (1,2,2,1,1,2,1,2,2,2,2,3,1,9,4,5,6,8,7,1,1);

          dcl NO           init ("no") char (2) int static options (constant);
	dcl YES          init ("yes") char (3) int static options (constant);
	dcl ASK          init ("ask") char (3) int static options (constant);
          dcl INVALID_CHARS init (" <()[]{}*,;") char (12) int static options (constant);
	dcl VALID_LENGTH fixed bin init (32) int static options (constant);
	
         	dcl error_table_$bigarg fixed bin(35) ext static;
	dcl error_table_$bad_arg fixed bin(35) ext static;
          dcl error_table_$smallarg fixed bin(35) ext static;
          dcl iod_info_$generic_type entry (char(*), char(32), fixed bin(35));

	vrv_code = 0;
          goto OPTION (TEST_VALUE_ARRAY (vrv_index));
	
OPTION (1):	/* yes_no_ask */
	if ^(vrv_out_value = YES |
	     vrv_out_value = NO |
	     vrv_out_value = ASK)
	     then vrv_code = error_table_$bad_arg;
	return;

OPTION (2):	/* yes_no */
	if ^(vrv_out_value = YES | vrv_out_value = NO)
	     then vrv_code = error_table_$bad_arg;
	return;
OPTION (3):	/* save messages in mailbox name */
	if length (vrv_out_value) > VALID_LENGTH
	     then code = error_table_$smallarg;
	else
	     if search (vrv_out_value, INVALID_CHARS) ^= 0 then 
	     code = error_table_$bad_arg;
	return;

OPTION (4):	/* header */
	if length(vrv_out_value) > 64
	     then vrv_code = error_table_$bigarg;
          return;

OPTION (5):	/* destination */
	if length (vrv_out_value) < 0 | length (vrv_out_value) > 20
	     then vrv_code = error_table_$bigarg;
	return;

OPTION (6):	/* station */
	if rtrim(vrv_out_value) = "default" then ;
	else do;
	     if length(vrv_out_value) > 24
	     then code = error_table_$smallarg;
	     else call iod_info_$generic_type ((vrv_out_value), generic_type, vrv_code);
	     end;
	return;

OPTION (7):	     /* margin */
	    
	non_number = verify (vrv_out_value, "-0123456789");
	if non_number ^= 0
	     then vrv_code = error_table_$bad_arg;
	else
	     if (fixed(vrv_out_value))  < 0 |
	        (fixed(vrv_out_value))  > 20
	     then vrv_code = error_table_$bigarg;
	return;

OPTION (8):	     /* copies */
	non_number = verify (vrv_out_value, "-0123456789");
	if non_number ^= 0
	     then vrv_code = error_table_$bad_arg;
	else
	     if (fixed(vrv_out_value))  < 1 |
	        (fixed(vrv_out_value))  > 30
	     then vrv_code = error_table_$bigarg;
	return;

OPTION (9):             /* no check */
               return;

     end validate_returned_value;
%page;
get_default_value: proc (gdv_index, gdv_out_value);
	         
         dcl gdv_index             fixed bin;
         dcl gdv_out_value         char (*) var;

         dcl GDV_DEFAULT_CLASS_ARRAY dim (1:21) fixed bin int static options (constant) init
         (1,1,2,1,1,2,1,2,1,1,1,3,2,4,5,5,5,5,5,1,1);

         goto OPTION (GDV_DEFAULT_CLASS_ARRAY (gdv_index));

OPTION (1):      /* no */
         gdv_out_value = "no";
         return;
OPTION (2):      /* yes */
         gdv_out_value = "yes";
         return;
OPTION (3):      /* ask */
         gdv_out_value = "ask";
         return;
OPTION (4):      /* version */
         gdv_out_value = xmail_version;
         return;
OPTION (5):      /* all other */
         return;
     end get_default_value;
%include xmail_data;
%include access_mode_values;


     end xmail_value_;




		    xmail_window_manager_.pl1       09/02/88  0759.6r w 09/02/88  0745.0      237213



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




/****^  HISTORY COMMENTS:
  1) change(86-01-28,Blair), approve(86-02-26,MCR7358),
     audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062):
     Signal reissue_query from the quit handler so that the choice menu will
     be redrawn or the question the user quit out of will be reprompted after
     a quit or a disconnect.  TRs 18711 18974.
  2) change(87-02-10,Blair), approve(87-02-10,MCR7618),
     audit(87-04-15,RBarstad), install(87-04-26,MR12.1-1025):
     Adjust the screen after a reconnect so that we don't attempt to rebuild
     menus on a reply and we print the "Editing..." line when the menus are
     suppressed on a send.  Error_list #114.
                                                   END HISTORY COMMENTS */


xmail_window_manager_: proc ();

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

/* BEGIN DESCRIPTION

function:

     This subroutine handles xmail window management.  It contains the
     following entrypoints:

          create_windows       -- creates the windows needed by xmail.
			    These windows are created in the user_io
			    window.
          destroy_windows      -- destroys all of the windows created by
			    the create_windows entrypoint.
	set_sw_size          -- alters the size of the status window and
			    has the surrounding windows compensate.
	set_menu_window_size -- alters the size of the menu window and
			    has the surrounding windows compensate.
          reconnect            -- resets the window status on all windows
			    and redisplays the whole screen if it
			    was found that there is "window status
			    pending".
          reconnect_test       -- like reconnect but also returns a bit
			    indicating whether the current quit condition
			    is a reconnect quit ("1"b = reconnect).
          quit_handler         -- like reconnect_test but also queries the
   			    user if the quit is not a reconnect quit.
			    Returns "1"b  if the quit is not a reconnect
			    AND if the user says he really wants to quit.
	suppress_menu        -- resizes the bottom window to all but the
                                  size of the status window, which will display
	                        an editing message. The whole bottom window
	                        can then be used for editing. Used before
                                  call to emacs_.
	restore_menu         -- restores the previous bottom window that was
	                        saved in suppress_menu.  Used after call to 
	                        emacs_.
*/

/************************************************************************/

/* history:          Written 1/8/82 by Suzanne Krupp

   83-07-28 DJ Schimke: Removed unreferenced dcl of video_data_$terminal_iocb.
  
   83-09-14 DJ Schimke: Modified to save the original user_io iocb in xmail 
   data rather than an internal static. This allows xmail_redisplay_ to clear
   xmail's portion of the user's screen. TR 12413

   84-04-06 DJ Schimke: Corrected the reference to error_table_$badcall which 
   was incorrectly spelled "bad_call". TR 17252

   84-06-22 DJ Schimke: Changed xmail to resize user_i/o rather than syning
   user_i/o to xmail_bottom_window. This allows user specified keybindings and
   more prompts to be supported from within xmail. The code that cleared the
   overlapping regions after resizing the windows was simplified by a single
   call to clear the bottom window. xmail error list #92

   84-09-20 JG Backs: Added 2 new entrypoints, suppress_menu and restore_menu,
   to support the new personalization option "Remove Menu While Editing".

   84-11-13 JG Backs: Added a 1 bit input parameter "condition_signalled"
   to entrypoint destroy_windows, which is "1" if procedure is called during
   condition cleanup and "0" all other times.  This bit is tested to prevent
   the screen from being cleared during a true cleanup condition.  The xmail
   module was also modified because it calls this entrypoint when the user
   exits xmail, and the parameter indicates if screen output should be avoided.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     code		 fixed bin (35);
	dcl     new_window_height	 fixed bin parameter;

/* AUTOMATIC */

	dcl     any_window_status_pending
				 bit (1) aligned;
	dcl     delta		 fixed bin;
	dcl     np_code		 fixed bin (35);
	dcl     reconnect_sw	 bit (1) aligned;
	dcl     stack_ptr		 ptr;
	dcl     yes_sw		 bit (1) aligned;

	dcl     1 auto_window_status_info aligned like window_status_info;
	dcl     1 bottom_window_info	 like window_position_info;
	dcl     1 cond_info		 like condition_info;
	dcl     1 menu_window_info	 like window_position_info;
	dcl     1 status_window_info	 like window_position_info;


/* BUILTINS */

	dcl     (addr, null)	 builtin;

/* ENTRIES */

	dcl     find_condition_frame_	 entry (ptr) returns (ptr);
	dcl     find_condition_info_	 entry (ptr, ptr, fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     window_$overwrite_text entry (ptr, char (*), fixed bin (35));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     window_$position_cursor entry (ptr, fixed bin, fixed bin, fixed bin (35));
	dcl     xmail_error_$no_code	 entry () options (variable);
	dcl     xmail_error_$no_print	 entry () options (variable);
	dcl     xmail_get_str_$yes_no	 entry (char (*) var, bit (1) aligned);
	dcl     xmail_redisplay_$all	 entry ();
	dcl     xmail_window_manager_$destroy_windows entry (bit (1));

/* CONSTANTS */

	dcl     COL1		 fixed bin init (1) int static options (constant);
	dcl     LINE1		 fixed bin init (1) int static options (constant);
	dcl     LOG		 char (1) init ("l") int static options (constant);
	dcl     MAX_SW_HEIGHT	 fixed bin init (2) int static options (constant);
	dcl     MENU_WINDOW_HEIGHT	 fixed bin init (1) int static options (constant);
	dcl     MIN_SW_HEIGHT	 fixed bin init (1) int static options (constant);
	dcl     NAME		 char (21) init ("xmail_window_manager_") int static options (constant);
	dcl     STATUS_WINDOW_HEIGHT	 fixed bin init (1) int static options (constant);
	dcl     XWMSM_HEADER	 char (45) init ("                                   Editing...") int static options (constant);

/* EXTERNAL STATIC */

	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$badcall	 fixed bin (35) ext static;
	dcl     iox_$user_io	 ptr ext static;
	dcl     video_data_$terminal_iocb ptr ext static;
	dcl     video_et_$window_status_pending fixed bin (35) ext static;
	dcl     xmail_err_$insuff_room_for_xmail fixed bin (35) ext static;

/* INTERNAL STATIC */

	dcl     1 user_io_window_info	 like window_position_info int static;

/* BEGIN */

	call xmail_error_$no_print (error_table_$badcall, NAME, LOG);

create_windows: entry (code);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry creates the xmail windows in the user_io window. There are four xmail     */
/* windows created: a status window (top), a multics mode status window (overlaps line  */
/* 1 of status window), a menu window (middle), and a user_io window                    */
/* (bottom).							        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	code = 0;
	xmail_windows.status.iocb, xmail_windows.mm_status.iocb, xmail_windows.menu.iocb, xmail_windows.bottom.iocb = null;

	user_io_window_info.version = window_position_info_version;
	call iox_$control (iox_$user_io, "get_window_info", addr (user_io_window_info), code);
	if code ^= 0 then go to CREATE_EXIT;

	if user_io_window_info.height < xmail_windows.min_lines_needed
	then do;
	     code = xmail_err_$insuff_room_for_xmail;
	     go to CREATE_EXIT;
	end;

	call make_window ("xmail_status_window",	/* window name */
	     user_io_window_info.line,		/* line origin */
	     STATUS_WINDOW_HEIGHT,			/* height */
	     user_io_window_info.width,		/* width */
	     xmail_windows.status,			/* window info */
	     code);
	if code ^= 0
	then do;
	     call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */
	     go to CREATE_EXIT;
	end;

	call make_window ("xmail_mm_status_window",	/* window name */
	     user_io_window_info.line,		/* line origin */
	     1,					/* height */
	     user_io_window_info.width,		/* width */
	     xmail_windows.mm_status,			/* window info */
	     code);
	if code ^= 0
	then do;
	     call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */
	     go to CREATE_EXIT;
	end;

	call make_window ("xmail_menu_window",
	     user_io_window_info.line + STATUS_WINDOW_HEIGHT,
	     MENU_WINDOW_HEIGHT,
	     user_io_window_info.width,
	     xmail_windows.menu,
	     code);
	if code ^= 0 then do;
	     call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */
	     go to CREATE_EXIT;
	end;

	xmail_windows.bottom.iocb = iox_$user_io;
	xmail_windows.bottom.position.version = window_position_info_version_1;
	xmail_windows.bottom.position.line = user_io_window_info.line +
	     STATUS_WINDOW_HEIGHT + MENU_WINDOW_HEIGHT;
	xmail_windows.bottom.position.width = user_io_window_info.width;
	xmail_windows.bottom.position.height = user_io_window_info.height
	     - (STATUS_WINDOW_HEIGHT + MENU_WINDOW_HEIGHT);
	call iox_$control (xmail_windows.bottom.iocb, "set_window_info",
	     addr (xmail_windows.bottom.position), code);
	if code ^= 0 then do;
	     call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */
	     go to CREATE_EXIT;
	end;

CREATE_EXIT:
	return;					/* create_windows entry */

destroy_windows: entry (condition_signalled);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry destroys all xmail windows.				        */
/*    Input parameter indicates the following:			                  */
/*    condition_signalled = 1 to signal cleanup condition.			        */
/*    condition_signalled = 0 to signal no condition.			        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* PARAMETERS */

	dcl     condition_signalled	 bit (1);		/* input parameter */
						/* 1 = cleanup condition */
						/* 0 = no condition */

/* BEGIN */

	xmail_windows.bottom.iocb = iox_$user_io;
	xmail_windows.bottom.position.version = window_position_info_version_1;
	xmail_windows.bottom.position.line = user_io_window_info.line;
	xmail_windows.bottom.position.width = user_io_window_info.width;
	xmail_windows.bottom.position.height = user_io_window_info.height;
	call iox_$control (xmail_windows.bottom.iocb, "set_window_info",
	     addr (xmail_windows.bottom.position), (0));

/* Do not clear screen if cleanup condition was signalled */

	if ^condition_signalled
	then call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore error */
	call unmake_window (xmail_windows.status.iocb);
	call unmake_window (xmail_windows.mm_status.iocb);
	call unmake_window (xmail_windows.menu.iocb);

	return;					/* destroy_windows entry */

set_sw_size: entry (new_window_height, code);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry sets the size of the status window taking or giving space from/to the     */
/* menu window.							        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	code = 0;

	if new_window_height = xmail_windows.status.height
	then go to SET_SW_EXIT;

	if new_window_height < MIN_SW_HEIGHT | new_window_height > MAX_SW_HEIGHT
	then do;
	     code = error_table_$bad_arg;
	     go to SET_SW_EXIT;
	end;

	delta = new_window_height - xmail_windows.status.height;

	status_window_info = xmail_windows.status.position;
	status_window_info.height = status_window_info.height + delta;

	menu_window_info = xmail_windows.menu.position;
	menu_window_info.origin.line = menu_window_info.origin.line + delta;

	bottom_window_info = xmail_windows.bottom.position;
	bottom_window_info.height = bottom_window_info.height - delta;
	bottom_window_info.origin.line = bottom_window_info.origin.line + delta;

	call iox_$control (xmail_windows.status.iocb, "set_window_info", addr (status_window_info), code);
	if code ^= 0
	then do;
	     call reset_window_sizes ();
	     go to SET_SW_EXIT;
	end;

	call iox_$control (xmail_windows.menu.iocb, "set_window_info", addr (menu_window_info), code);
	if code ^= 0
	then do;
	     call reset_window_sizes ();
	     go to SET_SW_EXIT;
	end;

	call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), code);
	if code ^= 0
	then do;
	     call reset_window_sizes ();
	     go to SET_SW_EXIT;
	end;

	call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore any error */

	xmail_windows.status.position = status_window_info;
	xmail_windows.menu.position = menu_window_info;
	xmail_windows.bottom.position = bottom_window_info;

SET_SW_EXIT:
	return;					/* set_sw_size entry */

set_menu_window_size: entry (new_window_height, code);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry sets the size of the menu window taking or giving space to/from the       */
/* bottom window.							        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	code = 0;

	if new_window_height = xmail_windows.menu.height
	then go to SET_MENU_EXIT;

	if new_window_height < 1 | new_window_height >= xmail_windows.menu.height + xmail_windows.bottom.height
	then do;
	     code = error_table_$bad_arg;
	     go to SET_MENU_EXIT;
	end;

	delta = new_window_height - xmail_windows.menu.height;

	menu_window_info = xmail_windows.menu.position;
	menu_window_info.height = menu_window_info.height + delta;

	bottom_window_info = xmail_windows.bottom.position;
	bottom_window_info.height = bottom_window_info.height - delta;
	bottom_window_info.origin.line = bottom_window_info.origin.line + delta;

	call iox_$control (xmail_windows.menu.iocb, "set_window_info", addr (menu_window_info), code);
	if code ^= 0
	then do;
	     call reset_window_sizes ();
	     go to SET_MENU_EXIT;
	end;

	call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), code);
	if code ^= 0
	then do;
	     call reset_window_sizes ();
	     go to SET_MENU_EXIT;
	end;

	call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore any error */

	xmail_windows.menu.position = menu_window_info;
	xmail_windows.bottom.position = bottom_window_info;

SET_MENU_EXIT:
	return;					/* set_menu_window_size entry */

quit_handler: entry returns (bit (1) aligned);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry is called by the xmail pl1 modules that call emacs_.  It is called on a   */
/* quit condition to protect the user from accidentally quitting before the current     */
/*  action is finished (ie. the message is not saved or sent.) It returns true only if  */
/* the quit is not a reconnect quit and the user says yes to the prompt.  Either way    */
/* this entry also checks status pending for any of the windows and resets it.  If any  */
/* window had a status pending xmail_redisplay_$all is called to reset the display of   */
/*  all windows.							        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

dcl  reissue_query condition;
	    

	call check_window_status;
	call check_for_reconnect (reconnect_sw);

	if reconnect_sw then do;
	     yes_sw = "0"b;		/* reconnect, don't quit */
	     signal reissue_query;
	     end;
	else do;
	     call xmail_get_str_$yes_no ("Any pending work will be lost."
		|| "  Do you really want to quit?", yes_sw); /* BREAK hit, query before quitting */
	     if ^yes_sw then
		signal reissue_query;
	     end;
			     
	return (yes_sw);

reconnect: entry ();

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry is called to test for window status pending on the xmail windows and      */
/* reset it on any window that needs resetting. If any window status is pending the     */
/* xmail windows are redisplayed.					        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	call check_window_status;
	return;					/* reconnect entry */

reconnect_test: entry returns (bit (1) aligned);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*								        */
/* This entry is called only by the xmail emacs extensions to determine if the quit     */
/* that they have detected is really a quit or whether it is actually a reconnect quit. */
/* It returns true if the quit is a reconnect quit, false otherwise.	                  */
/* Either way this entry also checks status pending for any of the windows and resets   */
/* it. If any window had a status pending xmail_redisplay_$all is called to reset the   */
/* display of all windows.     					        */
/*								        */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

dcl  ioa_$ioa_switch_nnl entry() options(variable);
dcl  xmail_value_$get_with_default entry options(variable);
dcl  response char (3) var;

	call check_window_status;

	call check_for_reconnect (reconnect_sw);
          if reconnect_sw then  do;
	     if (xmail_data.remove_menus & ^xmail_data.reply_request) then do;
	          call window_$clear_window (xmail_windows.status.iocb, (0));
		call window_$overwrite_text (xmail_windows.status.iocb, XWMSM_HEADER, code);
		end;
	     if xmail_data.reply_request then do;
		call xmail_value_$get_with_default ("original_up_window_yn", "yes", response, (0));
/* The following literal is found in xmail_reply_msg_ and must be duplicated here to make the screen 
   look the same.  It only appears when the original message is in an upper window and the reply is
   in a second window.  */
		if response = "yes" then call ioa_$ioa_switch_nnl (xmail_windows.menu.iocb, "     *** Use ESC l  to view previous page,  ESC h  to view next page ***");
		end;
	     end;
		     	     
	return (reconnect_sw);			/* reconnect_test entry */

suppress_menu: entry ();

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*                                                                          */
/*  This entry is called by xmail pl1 modules that call emacs_ with the     */
/*  personalization option "Remove Menu While Editing" in force.  The only  */
/*  exception is xmail_reply_msgs_, since that always removes the menu.     */
/*                                                                          */
/*  This entry resizes the bottom window so the previous window info can be */
/*  restored via a call to another entrypoint, restore_menu, immediately    */
/*  after emacs_ call.  By resizing the bottom window, emacs can use all    */
/*  but the status window to do the editing.                                */
/*                                                                          */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* AUTOMATIC */

	dcl     xwmsm_code		 fixed bin (35);

/* CONSTANTS */

	dcl     XWMSM_ERROR		 char (31) init ("Cannot remove menu as requested") int static options (constant);

/* BEGIN xmail_window_manager_$suppress_menu */

	call window_$clear_window (xmail_windows.status.iocb, (0)); /* ignore code */
	call window_$overwrite_text (xmail_windows.status.iocb, XWMSM_HEADER, xwmsm_code);
	if xwmsm_code ^= 0
	then call xmail_error_$no_code (xwmsm_code, NAME, "s", XWMSM_ERROR);
	bottom_window_info = xmail_windows.bottom.position;
	delta = xmail_windows.menu.height + xmail_windows.status.height - 1;
	bottom_window_info.height = bottom_window_info.height + delta;
	bottom_window_info.origin.line = bottom_window_info.origin.line - delta;

	call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), xwmsm_code);

	if xwmsm_code ^= 0
	then call xmail_error_$no_code (xwmsm_code, NAME, "s", XWMSM_ERROR);

	call window_$clear_window (iox_$user_io, (0));	/* ignore code */

suppress_menu_EXIT:
	return;					/* suppress_menu entry */

restore_menu: entry ();

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*                                                                          */
/*  This entry is used to restore the menu window by resizing the bottom    */
/*  window from the previous information.  It is called immediately         */
/*  following the call to emacs_ in those xmail modules that use the editor.*/
/*                                                                          */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* AUTOMATIC */

	dcl     xwmrm_code		 fixed bin (35);

/* BEGIN xmail_window_manager_$restore_menu */

	call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), xwmrm_code);
	if xwmrm_code ^= 0
	then call xmail_error_$no_code (xwmrm_code, NAME, "s", "Cannot restore menu information");


restore_menu_EXIT:
	return;					/* restore_menu entry */

/* I N T E R N A L  P R O C E D U R E S */

check_for_reconnect: proc (reconnect_quit);

	dcl     reconnect_quit	 bit (1) aligned parameter;

	reconnect_quit = "0"b;
	cond_info.version = condition_info_version_1;
	cond_info.info_ptr = null ();
	cond_info.flags.pad1 = "0"b;
	cond_info.pad2 = "0"b;
	cond_info.pad3 = "0"b;
	stack_ptr = find_condition_frame_ (null ());
	if stack_ptr ^= null () then do;
	     call find_condition_info_ (stack_ptr, addr (cond_info), (0)); /* test cond_info.info_ptr rather than code */
	     if cond_info.info_ptr ^= null () then do;
		quit_info_ptr = cond_info.info_ptr;
		reconnect_quit = quit_info.switches.reconnection_quit;
	     end;
	end;
     end check_for_reconnect;

check_window_status: proc;

	any_window_status_pending = "0"b;

	call window_$position_cursor (xmail_windows.status.iocb, LINE1, COL1, np_code);
	if np_code = video_et_$window_status_pending
	then do;
	     call fix_status (xmail_windows.status.iocb);
	     any_window_status_pending = "1"b;
	end;
	else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG);

	call window_$position_cursor (xmail_windows.mm_status.iocb, LINE1, COL1, np_code);
	if np_code = video_et_$window_status_pending
	then do;
	     call fix_status (xmail_windows.mm_status.iocb);
	     any_window_status_pending = "1"b;
	end;
	else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG);

	call window_$position_cursor (xmail_windows.menu.iocb, LINE1, COL1, np_code);
	if np_code = video_et_$window_status_pending
	then do;
	     call fix_status (xmail_windows.menu.iocb);
	     any_window_status_pending = "1"b;
	end;
	else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG);

	call window_$position_cursor (xmail_windows.bottom.iocb, LINE1, COL1, np_code);
	if np_code = video_et_$window_status_pending
	then do;
	     call fix_status (xmail_windows.bottom.iocb);
	     any_window_status_pending = "1"b;
	end;
	else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG);

	if any_window_status_pending then call xmail_redisplay_$all ();
     end check_window_status;

fix_status: proc (P_iocb_ptr);
	dcl     P_iocb_ptr		 ptr parameter;

	auto_window_status_info.version = window_status_version;
	call iox_$control (P_iocb_ptr, "get_window_status", addr (auto_window_status_info), np_code);
	if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG);
     end;

make_window: proc (name, line_origin, height, width, window, code);

/* Automatic */

	dcl     code		 fixed bin (35);
	dcl     height		 fixed bin;
	dcl     line_origin		 fixed bin;
	dcl     name		 char (*);
	dcl     width		 fixed bin;
	dcl     1 window		 aligned like xmail_window_info_format;

/* Builtin */

	dcl     (addr, null)	 builtin;

/* Entry */

	dcl     iox_$find_iocb	 entry (char (*), ptr, fixed bin (35));
	dcl     window_$create	 entry (ptr, ptr, ptr, fixed bin (35));

	window.iocb = null;
	window.position.version = window_position_info_version;
	window.position.line = line_origin;
	window.position.height = height;
	window.position.width = width;

	call iox_$find_iocb (name, window.iocb, code);
	if code = 0
	then call window_$create (video_data_$terminal_iocb, addr (window.position), window.iocb, code);

	return;
     end make_window;

unmake_window: proc (window_iocbp);

/* Parameter */

	dcl     window_iocbp	 ptr;

/* Builtin */

	dcl     null		 builtin;

/* Entries */

	dcl     window_$destroy	 entry (ptr, fixed bin (35));

	if window_iocbp ^= null
	then do;
	     call window_$destroy (window_iocbp, (0));	/* ignore code */
	     window_iocbp = null;
	end;
	return;

     end unmake_window;

reset_window_sizes: proc ();

	call iox_$control (xmail_windows.status.iocb, "set_window_info", addr (xmail_windows.status.position), (0)); /* ignore error */
	call iox_$control (xmail_windows.menu.iocb, "set_window_info", addr (xmail_windows.menu.position), (0));
	call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), (0));

     end reset_window_sizes;

%include condition_info;
%page;
%include condition_info_header;
%page;
%include quit_info;
%page;
%include xmail_windows;
%page;
%include window_status;
%page;
%include xmail_data;

     end xmail_window_manager_;




		    xmail_write_msgs_.pl1           09/02/88  0759.6r w 09/02/88  0744.7       97803



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

xmail_write_msgs_: proc (xwm_mailbox_ptr, xwm_curr_msgsp);

/* BEGIN DESCRIPTION

function: This procedure writes a copy of the current message(s) to a
          Multics segment in a format similar to that which is
          displayed with the "Display" request.  It is executed when
          the "Write" request on either the "Process Incoming Mail"
          or "Process Filed Mail" menu is selected.

description: The user is prompted for a file name. If the segment does
             not exist, it is created and the current message(s) are
             written to it. If it does exist, the current message(s)
             will be appended to the end.

known bugs:  This code does not check for the remote possibility that
             the user has rw permission on the segment to be written,
             but null access to the directory containing that segment.
             Call to adjust_bit_count_ will fail. JG Backs 84-07-18.

history:  

   84-07-12  JG Backs: Written from xmail_dprint_msgs_.pl1 

   84-11-07  JG Backs: Deleted "This is an internal programming error."
   from the error message at the call to subroutine adjust_bit_count_.
   Audit change.

END DESCRIPTION
*/

/* PARAMETERS */

	dcl     (xwm_mailbox_ptr, xwm_curr_msgsp) ptr;	/* input pointers to mailbox and current messages */


/* EXTERNAL STATIC */

	dcl     error_table_$incorrect_access fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     xmail_err_$no_curr_msgs fixed bin (35) ext static;

/* ENTRIES */

	dcl     adjust_bit_count_	 entry (char (168) aligned, char (32) aligned, bit (1) aligned,
				 fixed bin (35), fixed bin (35));
	dcl     delete_$ptr		 entry (ptr, bit (6) aligned, char (*), fixed bin (35));
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     hcs_$append_branch	 entry (char (*), char (*), fixed bin (5), fixed bin (35));
	dcl     hcs_$set_bc		 entry (char (*), char (*), fixed bin (24), fixed bin (35));
	dcl     hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry () options (variable);
	dcl     ioa_$ioa_switch_nnl	 entry () options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$user_io	 ptr ext static;
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     window_$clear_window	 entry (ptr, fixed bin (35));
	dcl     xmail_display_msgs_$ff entry (ptr, ptr, ptr);
	dcl     xmail_error_$code_first entry () options (variable);
	dcl     xmail_get_str_	 entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var);
	dcl     xmail_validate_$curr_msgs entry (ptr, fixed bin (35));
	dcl     xmail_validate_$mbx	 entry (ptr, fixed bin (35));


/* CONDITIONS */

	dcl     cleanup		 condition;	/* QUIT handling */


/* INTERNAL AUTOMATIC */

	dcl     xwm_bit_count	 fixed bin (24);	/* bit count of segment */
	dcl     xwm_code		 fixed bin (35);	/* for output of status code during calls */
	dcl     xwm_dname		 char (168);	/* directory of segment */
	dcl     xwm_ename		 char (32);	/* entry name of segment */
	dcl     xwm_iocb_ptr	 ptr;		/* pointer to control block for I/O switch */
	dcl     xwm_new_seg		 bit (1);		/* flag; ON => new segment to be created */
	dcl     xwm_new_path	 char (200) varying;/* pathname of segment */
	dcl     xwm_seg_ptr		 ptr;		/* pointer to segment */
	dcl     xwm_type		 fixed bin (2);	/* for output of type during calls, not queried */
	dcl     xwm_unused_return_bc	 fixed bin (35);	/* for output of bit count during calls, not queried */


/* CONSTANTS */

	dcl     xwm_CHASE		 fixed bin (1) init (1) int static options (constant);
	dcl     xwm_DELETE_SEG	 bit (6) aligned init ("000100"b) int static options (constant);
	dcl     xwm_FILE_PROMPT	 char (27) varying init ("Enter the name of the file:") int static options (constant);
	dcl     xwm_LAST_CHAR	 bit (1) aligned init ("1"b) int static options (constant);
	dcl     xwm_ME_CHAR		 char (17) init ("xmail_write_msgs_") int static options (constant);
	dcl     xwm_ME_ENTRY	 entry init (xmail_write_msgs_) options (variable);
	dcl     xwm_PATH_NAME	 char (9) init ("path_name") int static options (constant);
	dcl     xwm_PROMPT_REPLIES_HELP char (28) init ("xmail_prompt_replies.gi.info") int static options (constant);
	dcl     xwm_UNUSED_BIT	 bit (1) aligned init ("0"b) int static options (constant);


/* BUILTINS */

	dcl     (codeptr, null, rtrim) builtin;


%page;
/* INCLUDE FILES */

%include access_mode_values;
%page;
%include iox_modes;
%page;
%include mlsys_mailbox;
%page;
%include mlsys_message;
%page;
%include xmail_curr_msg_info;
%page;
%include xmail_data;
%page;
%include xmail_responses;

/* BEGIN */

	xwm_iocb_ptr, xwm_seg_ptr = null;
	xwm_new_seg = "0"b;

	on cleanup call CLEANUP;

/* Validate input parameters */

	call xmail_validate_$mbx (xwm_mailbox_ptr, xwm_code);
	if xwm_code ^= 0
	then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		"^/  Invalid mailbox structure.  This is an internal programming error.");

	if xwm_curr_msgsp = null
	then call xmail_error_$code_first (xmail_err_$no_curr_msgs, xwm_ME_CHAR, "i");
	else do;
	     call xmail_validate_$curr_msgs (xwm_curr_msgsp, xwm_code);
	     if xwm_code ^= 0
	     then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		     "^/  Invalid message structure. This is an internal programming error.");
	end;

	curr_msgsp = xwm_curr_msgsp;
	mailbox_ptr = xwm_mailbox_ptr;

/* Request input of file name (segment) */

	xwm_new_path = "";
	do while (xwm_new_path = "");
	     call xmail_get_str_ (xwm_FILE_PROMPT, "", xwm_PROMPT_REPLIES_HELP, xwm_PATH_NAME, xwm_new_path);
	     if xwm_new_path = ""
	     then call ioa_ ("^/  You must provide a file name.");
	     if xwm_new_path = LIST
	     then do;
		call ioa_ ("^/  A list of all possible files you can write to is not available with ??");
		xwm_new_path = "";
	     end;
	end;					/* do while */

	call expand_pathname_ ((xwm_new_path), xwm_dname, xwm_ename, xwm_code);
	if xwm_code ^= 0
	then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		"^/  ""^a"" is not a valid file name.", xwm_new_path);

/* Determine status of segment name */

	call hcs_$status_minf (xwm_dname, xwm_ename, xwm_CHASE, xwm_type, xwm_bit_count, xwm_code);
	if xwm_code ^= 0
	then do;
	     if xwm_code = error_table_$noentry
	     then do;
						/* Segment does not exist; create new segment */

		xwm_new_seg = "1"b;

		call hcs_$append_branch (xwm_dname, xwm_ename, RW_ACCESS_BIN, xwm_code);
		if xwm_code ^= 0
		then if xwm_code = error_table_$incorrect_access
		     then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
			     "^/  You do not have correct access to directory ""^a"" to create file ""^a"".",
			     xwm_dname, xwm_ename);
		     else call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
			     "^/  Unable to create new file ""^a"" in directory ""^a"".",
			     xwm_ename, xwm_dname);
	     end;
	     else if xwm_code = error_table_$incorrect_access
	     then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		     "^/  You do not have correct access to file ""^a"" in directory ""^a"".",
		     xwm_ename, xwm_dname);
	     else call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		     "^/  There is an error with file ""^a"" in directory ""^a"".",
		     xwm_ename, xwm_dname);

	end;					/* do */

/* Now try to write to segment */

	call initiate_file_ (xwm_dname, xwm_ename, RW_ACCESS, xwm_seg_ptr, xwm_bit_count, xwm_code);
	if xwm_code ^= 0
	then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		"^/  Unable to initiate file ""^a"" in directory ""^a"".",
		xwm_ename, xwm_dname);
	call iox_$attach_name (unique_chars_ ("0"b), xwm_iocb_ptr,
	     "vfile_ " || rtrim (xwm_dname) || ">" || (xwm_ename) || " -extend", codeptr (xwm_ME_ENTRY), xwm_code);
	if xwm_code = 0
	then call iox_$open (xwm_iocb_ptr, Stream_input_output, xwm_UNUSED_BIT, xwm_code);
	if xwm_code ^= 0
	then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		"^/  Unable to prepare output switch to file. This is an internal programming error.");

	if ^xwm_new_seg
	then call ioa_$ioa_switch_nnl (xwm_iocb_ptr, "^|");

	call xmail_display_msgs_$ff (mailbox_ptr, curr_msgsp, xwm_iocb_ptr);

	call adjust_bit_count_ ((xwm_dname), (xwm_ename), xwm_LAST_CHAR, xwm_unused_return_bc, xwm_code);
	if xwm_code ^= 0
	then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		"^/  Unable to adjust bit count of file.");

/* Complete by destroying I/O control block pointer, clearing screen, & writing message  to user */

	call close_detach_and_destroy (xwm_iocb_ptr);

	call window_$clear_window (iox_$user_io, xwm_code);
	if xwm_code ^= 0
	then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q",
		"^/  Unable to clear window. This is an internal programming error.");

	call ioa_ ("Message^[s^] ^v(^d ^)^[written^;appended^] to ^a.", (curr_msgs.count > 1),
	     curr_msgs.count, curr_msgs.numbers, xwm_new_seg, xwm_ename);

	return;
%page;
/* Internal procedures */

close_detach_and_destroy: proc (cdad_iocb_ptr);

/* Internal procedure to finish with the control block pointer for the I/O switch */

/* PARAMETERS */

	dcl     cdad_iocb_ptr	 ptr;		/* input pointer to I/O control block */

/* BEGIN */

	if cdad_iocb_ptr ^= null
	then do;
	     call iox_$close (cdad_iocb_ptr, (0));	/* ignore code */
	     call iox_$detach_iocb (cdad_iocb_ptr, (0));	/* ignore code */
	     call iox_$destroy_iocb (cdad_iocb_ptr, (0)); /* ignore code */
	end;

     end close_detach_and_destroy;

CLEANUP: proc;

/* Internal procedure for cleanup condition:
            to delete non-null segment pointer if a new file,
            or restore bit count if existing file             */

/* BEGIN */

	call close_detach_and_destroy (xwm_iocb_ptr);

	if xwm_seg_ptr ^= null
	then if xwm_new_seg
	     then do;
		call delete_$ptr (xwm_seg_ptr, xwm_DELETE_SEG, "", xwm_code);
		if xwm_code = 0
		then xwm_seg_ptr = null;
	     end;
	     else call hcs_$set_bc (xwm_dname, xwm_ename, xwm_bit_count, (0)); /* ignore code */

     end CLEANUP;


     end xmail_write_msgs_;




		    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
