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 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 (" ... "); 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 " " ;;; 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:") "") ((samepnamep title "To:") "") ((or (and (samepnamep title "To:") (reply-mode)) (samepnamep title "cc:") (samepnamep title "bcc:")) "") ((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 '|__|)) (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- 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 "") (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 (" ... "); /* 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 */ dcl WHITE_SPACE_COMMA char (6) aligned static options (constant) init (" ,"); /* HT VT NL 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), "", 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