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 (32); dcl no_chars fixed bin (24); dcl restore_menu_needed bit (1) aligned; /* if remove menu */ dcl status fixed bin (35); dcl store_dir char (168); dcl store_file char (32) var; dcl stored_msg_ptr ptr; dcl suffix char (4); dcl temp_seg_ptr ptr; dcl type fixed bin (2); dcl unused_bit bit (1) aligned; dcl unused_bit2 bit (1) aligned; dcl user_msg_seg_entry_name char (32); /* ENTRIES */ dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl emacs_ entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl get_pdir_ entry () returns (char (168)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$make_seg entry options (variable); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$nnl entry () options (variable); dcl mail_system_$free_address_list entry (ptr, fixed bin (35)); dcl mail_system_$free_message entry (ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl xmail_error_$no_code entry options (variable); dcl xmail_process_user_msg_ entry (); /* no parameter */ dcl xmail_redisplay_$menu entry (); dcl xmail_sw_$redisplay entry (); dcl xmail_sw_$update_usage entry (char (*)); dcl xmail_window_manager_$quit_handler entry () returns (bit (1) aligned); dcl xmail_window_manager_$reconnect entry (); dcl xmail_window_manager_$suppress_menu entry (); dcl xmail_window_manager_$restore_menu entry (); /* BUILTINS */ dcl (addr, codeptr, divide, null, rtrim) builtin; /* BASED */ dcl based_string char (no_chars) based (temp_seg_ptr); /* INCLUDE FILES */ %include access_mode_values; %page; %include xmail_data; %page; %include xmail_send_mail; %page; %include window_dcls; /* BEGIN */ restore_menu_needed = "0"b; send_mail_info.stored_seg_ptr = null (); temp_seg_ptr = null (); stored_msg_ptr = null (); /* Update status window */ call xmail_sw_$update_usage (" "); call xmail_sw_$redisplay (); call ioa_$nnl (" "); /* Free any current address list(s), msg ptr, and create seg for Emacs to place new message in */ if P_store then suffix = "_ssm"; else do; suffix = "_sm "; if send_mail_info.new_msg_ptr ^= null () then do; call mail_system_$free_message (send_mail_info.new_msg_ptr, code); if code ^= 0 then send_mail_info.new_msg_ptr = null (); end; if send_mail_info.to_list_ptr ^= null () then do; call mail_system_$free_address_list (send_mail_info.to_list_ptr, code); if code ^= 0 then send_mail_info.to_list_ptr = null (); end; if send_mail_info.cc_list_ptr ^= null () then do; call mail_system_$free_address_list (send_mail_info.cc_list_ptr, code); if code ^= 0 then send_mail_info.cc_list_ptr = null (); end; /* Add reply-to handling */ if send_mail_info.reply_to_list_ptr ^= null () then do; call mail_system_$free_address_list (send_mail_info.reply_to_list_ptr, code); if code ^= 0 then send_mail_info.reply_to_list_ptr = null (); end; /* Add bcc handling */ if send_mail_info.bcc_list_ptr ^= null () then do; call mail_system_$free_address_list (send_mail_info.bcc_list_ptr, code); if code ^= 0 then send_mail_info.bcc_list_ptr = null (); end; /* Initialize the status of the message */ send_mail_info.msg_exists = "0"b; end; /* Set up quit and clean up conditions */ on condition (cleanup) begin; send_mail_info.msg_exists = "0"b; call CLEAN_UP; end; on condition (quit) begin; send_mail_info.msg_exists = "0"b; if xmail_window_manager_$quit_handler () then do; if restore_menu_needed then do; call xmail_window_manager_$restore_menu; call xmail_redisplay_$menu; end; call window_$clear_window (iox_$user_output, (0)); /* ignore code */ call ioa_ (HIT_QUIT_KEY); call CLEAN_UP; go to EXIT; end; end; /* Create seg (or trim existing seg) to be used by emacs for the user msg */ user_msg_seg_entry_name = xmail_data.actee.person || suffix; call hcs_$make_seg ("", user_msg_seg_entry_name, "", RW_ACCESS_BIN, temp_seg_ptr, code); if code = error_table_$namedup | code = error_table_$segknown then do; bit_count = 0; call terminate_file_ (temp_seg_ptr, bit_count, TERM_FILE_BC, code); end; if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); send_mail_info.emacs_seg_pathname = get_pdir_ (); if P_store then send_mail_info.stored_seg_ptr = temp_seg_ptr; else send_mail_info.emacs_seg_ptr = temp_seg_ptr; send_mail_info.emacs_seg_pathname = rtrim (send_mail_info.emacs_seg_pathname) || ">" || user_msg_seg_entry_name; /* Call emacs_ for preparing message. */ if ext_ptr = null () then do; call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "", ext_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT; end; emacs_flavor = "send"; bit_count = 0; call ioa_ ("... Please wait for editor ..."); /* Check personalization option to remove and restore menus while editing */ if xmail_data.remove_menus then do; call xmail_window_manager_$suppress_menu (); restore_menu_needed = "1"b; end; call emacs_ (iox_$user_output, (send_mail_info.emacs_seg_pathname), ext_pname, addr (emacs_flavor), status); if restore_menu_needed then do; call xmail_window_manager_$restore_menu (); call xmail_redisplay_$menu; restore_menu_needed = "0"b; end; call hcs_$status_mins (temp_seg_ptr, type, bit_count, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); if bit_count = 0 then do; call xmail_window_manager_$reconnect (); call ioa_ (HIT_QUIT_KEY); call CLEAN_UP; goto EXIT; end; if status = 1 then do; call store_msg (); goto EXIT; end; /* If forwarding message now then call proc for extracting the "subject", "text", and determining the primary and secondary (if any) recipients address list structures */ call xmail_process_user_msg_ (); /* no parameter */ EXIT: return; /* INTERNAL PROCEDURES */ store_msg: proc (); /* ENTRIES */ dcl xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35)); /* BASED */ dcl stored_string char (no_chars) based (stored_msg_ptr); /* BEGIN */ call xmail_select_file_$caller_msg ("deferred message", "defer", "", ALLOW_OLD, ALLOW_NEW, store_dir, store_file, "Type name you wish to give the ""deferred message"" (or ?? for list)", unused_bit, unused_bit2, code); if code ^= 0 then do; call ioa_ ("Sorry, ""deferred message"" not saved."); call CLEAN_UP; return; end; stored_msg_ptr = null (); call hcs_$make_seg (store_dir, rtrim (store_file) || ".defer", "", RW_ACCESS_BIN, stored_msg_ptr, code); if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segknown then do; call ioa_ ("Sorry, unable to save ""deferred message"". This is an internal error."); call CLEAN_UP; return; end; call terminate_file_ (stored_msg_ptr, bit_count, TERM_FILE_BC, code); /* Get number of chars in seg */ no_chars = divide (bit_count, 9, 17, 0); stored_string = based_string; call ioa_ ("Deferred message ""^a"" saved.", store_file); return; end store_msg; CLEAN_UP: proc (); if temp_seg_ptr ^= null () then call delete_$ptr (temp_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, code); send_mail_info.stored_seg_ptr = null (); /* send_mail_info.msg_exists = "0"b; * the above line was moved to the on unit so that the message will only * * be marked as non_existant on a true cleanup condition, but will other-* * wise still be available. */ send_mail_info.emacs_seg_pathname = ""; return; end CLEAN_UP; end xmail_prepare_msg_;  xmail_print_.pl1 10/28/88 1416.3r w 10/28/88 1302.1 237519 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-02-27,Blair), approve(86-02-27,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): 85-03-22 Joanne Backs: Modified to add 3 new entrypoints to $get_ and $set_: copies, left_margin, and notify. Added the conversion and size conditions and the CONVERT internal procedure to support these new printing options which can be set in the Personalize Exec Mail menu. 85-04-01 Joanne Backs: Added a short CONFIRM_FIRST internal procedure to display a prompt for changing the printing options before actually doing printing, but if the answer to the prompt is yes, just inform the user the option is not implemented yet. 85-04-02 Joanne Backs: Added calls to ioa_ to display a message to the user if the dprint was sucessfully submitted. A short message will be seen if the confirm option is set and the printing options have already been displayed, but the longer message at all other times. These messages were extracted from xmail_dprint_msgs_ and xmail_dprint_mlist_ to be consistant. 85-04-25 Joanne Backs: Added new internal procedures TEMP_CHANGE and PERFORM_CHANGE to allow the user to temporarily change any of the print options via a lower window dynamic menu. PERFORM_CHANGE will call the respective entrypoint in xmail_Review_Defaults_ to get the new value but will not permanently change the value in the value segment. 85-04-26 JG Backs: Modified CONFIRM_FIRST to output one prompt the first time the printing options are listed and output a different prompt after changes are made. 2) change(87-05-10,Gilcrease), approve(87-05-14,MCR7686), audit(88-02-01,Farley), install(88-02-02,MR12.2-1019): Update to version 9 dprint_arg. END HISTORY COMMENTS */ xmail_print_: proc; return; /* BEGIN DESCRIPTION function: xmail_print_ The xmail_print_ subroutine is a utility for requesting hard copy output in the xmail environment. It has entrypoints for creating a segment to contain the output until it is printed, submitting the segment to be printed, and for deleting a segment if the need to print it goes away before it is printed. Entries are also provided for manipulation of the stored attributes used to route output. Once a segment is submitted for printing it becomes the responsibility of xmail_print_. It determines the method of output delivery most suitable for the current user, delivers the output, and deletes the segment when delivery is known to have been accomplished. Future versions will actually interogate the user as to the delivery status of requested output and re-issue requests for lost output. The initial version will deliver output via dprint_ and depend upon the daemon to delete segments when they have been printed. history: Written 7/8/81 by Paul Kyzivat 81-07-20 Paul Kyzivat: Add the get/set entries. 82-10-11 Dave Schimke: Modified to use dp_args version 7. 84-09-27 Joanne Backs: Modified to use dp_args version 8. END DESCRIPTION */ /* PARAMETERS */ dcl id char (*) parameter, dir char (*) parameter, ent char (*) parameter, description char (*) parameter, value char (*) parameter, seg_ptr ptr parameter, dprint_arg_ptr ptr parameter, code fixed bin (35); /* AUTOMATIC */ dcl bc fixed bin (24), local_ent char (32), local_dir char (168), name_len fixed bin, suffix char (32), type fixed bin (2), yes_sw bit (1) aligned; /* CONSTANTS */ dcl CHASE init (1) fixed bin (1) static options (constant); dcl 1 CREATED_FILE_FORMAT static options (constant), 2 PREFIX char (3) init ("dp."), 2 UNIQUE char (15) init ("!??????????????"), 2 SUFFIX char (3) init (".**"); dcl DELETE_SEG init ("000100"b) bit (6) static options (constant); dcl NAME init ("xmail_print_") char (12) static options (constant); dcl NO char (2) init ("no") static options (constant); dcl RW_MODE fixed bin (5) init (01010b) static options (constant); dcl RW_MODE_INIT_FILE bit (3) init ("101"b) static options (constant); dcl YES char (3) init ("yes") static options (constant); /* EXTERNAL STATIC */ dcl error_table_$oldnamerr fixed bin (35) ext static, error_table_$bad_conversion fixed bin (35) ext static, error_table_$smallarg fixed bin (35) ext static; /* ENTRIES */ dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)), delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)), hcs_$append_branch entry (char (*), char (*), fixed bin (5), fixed bin (35)), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)), hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), ioa_ entry() options(variable), initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)), unique_chars_ entry (bit (*)) returns (char (15)), xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); /* CONDITIONS */ dcl cleanup condition; /* BUILTINS */ dcl (convert, length, min, null, rtrim, substr) builtin; /* INCLUDE FILES */ %include dprint_arg; %page; %include window_dcls; %page; %include xmail_data; /* ENTRYPOINTS */ /* xmail_print_$create_file This entry creates a file to be used for generation of hardcopy output. The directory is chosen automatically, and the entryname is generated uniquely but containing a caller specified identification. The directory and entrynames are returned to the caller. It is the responsibility of the caller to either request printing of the file or request its deletion. id is a brief (16 characters or less) identification of file contents. It will become part of the file name. dir (OUTPUT) is the directory containing the file. ent (OUTPUT) is the entryname of the created file. code (OUTPUT) is a system status code. */ create_file: entry (id, dir, ent, code); if id ^= "" then suffix = "." || substr (id, 1, min (length (id), 16)); else suffix = ""; ent = CREATED_FILE_FORMAT.PREFIX || unique_chars_ (""b) || suffix; dir = xmail_data.mail_dir; call hcs_$append_branch (dir, ent, RW_MODE, code); return; /* xmail_print_$create_seg This entry creates a segment to be used for generation of hardcopy output. The directory is chosen automatically, and the entryname is generated uniquely but containing a caller specified identification. The segment is initiated with a null reference name and a pointer returned to the caller. It is the responsibility of the caller to either request printing of the segment or request its deletion. id is a brief (16 characters or less) identification of segment contents. It will become part of the file name. seg_ptr (OUTPUT) is a pointer to the created segment. code See above. */ create_seg: entry (id, seg_ptr, code); seg_ptr = null; local_dir, local_ent = ""; on condition (cleanup) call delete_file (local_dir, local_ent, (0)); call create_file (id, local_dir, local_ent, code); if code = 0 then call initiate_file_ (local_dir, local_ent, RW_MODE_INIT_FILE, seg_ptr, bc, code); return; /* xmail_print_$submit_file This entry point requests that a file (identified by pathname) be printed. The file need not have been created by xmail_print_$create_file. Options controlling the printing are specified via a dprint_arg structure identical to that used in calling dprint_. A text description of the file or its contents is required, for use in conversing with the user about the file. This will be necessary in order to determine whether a file has been received by the user. dir (INPUT) is the directory containing the file to be printed. ent (INPUT) is the entryname of the file to be printed. description (INPUT) is a short (one line) description of the contents of the file, for purposes of communication with the user about it. dprint_arg_ptr (INPUT) is a pointer to a standard dprint arg structure. The following fields are ignored because they are determined internally: queue, pt_pch, heading, output_module, bit_count, destination, request_type, copies, lmargin, and notify. In addition, delete is assumed if the file being printed was created by xmail_print_$create_file or xmail_print_$create_seg. A null pointer may be passed, in which case defaults are used for all fields. code See above. */ submit_file: entry (dir, ent, description, dprint_arg_ptr, code); call hcs_$status_minf (dir, ent, CHASE, type, bc, code); if code = 0 then call SUBMIT (dir, ent, bc, description, dprint_arg_ptr, code); return; /* xmail_print_$submit_seg This entry point requests that a segment (identified by pointer) be printed. The segment need not have been created by xmail_print_$create_seg. Options controlling the printing are specified via a dprint_arg structure identical to that used in calling dprint_. A text description of the segment or its contents is required, for use in conversing with the user about the segment. This will be necessary in order to determine whether a segment has been received by the user. The segment will be terminated and seg_ptr set to null if and only if a zero is returned in code. seg_ptr is a pointer to the file to be printed. description See above. dprint_arg_ptr See above. code See above. */ submit_seg: entry (seg_ptr, description, dprint_arg_ptr, code); call hcs_$fs_get_path_name (seg_ptr, local_dir, name_len, local_ent, code); if code = 0 then call hcs_$status_mins (seg_ptr, type, bc, code); if code = 0 then call SUBMIT (local_dir, local_ent, bc, description, dprint_arg_ptr, code); if code = 0 then do; call hcs_$terminate_noname (seg_ptr, (0)); /* ignore error code */ seg_ptr = null; end; return; /* xmail_print_$delete_file This entry point is used to delete a file created by xmail_print_$create_file when it is determined that the file is not needed and will not be printed. This entry would normally be called from the cleanup condition handler of the procedure which requests the file. dir is the directory containing the file to be deleted, as returned by xmail_print_$create_file. ent is the entry name of the file to be deleted, as returned by xmail_print_$create_file. code See above. */ delete_file: entry (dir, ent, code); call delete_$path (dir, ent, DELETE_SEG, "", code); return; /* xmail_print_$delete_seg This entry point is used to delete a segment created by xmail_print_$create_seg when it is determined that the segment is not needed and will not be printed. This entry would normally be called from the cleanup condition handler of the procedure which requests the segment. seg_ptr is a pointer to the segment to be deleted, as returned by xmail_print_$create_seg. code See above. */ delete_seg: entry (seg_ptr, code); call delete_$ptr (seg_ptr, DELETE_SEG, "", code); if code = 0 then seg_ptr = null; return; /* xmail_print_$get_{heading destination request_type copies left_margin notify} These entries return the identified piece of information. They look for it in the value segment, and if not found they supply a default (if appropriate.) */ dcl ( DP_HEAD_VAR init ("dprint_heading"), DP_DEST_VAR init ("dprint_destination"), DP_RQT_VAR init ("dprint_request_type"), DP_COPIES_VAR init ("dprint_copies"), DP_LMARGIN_VAR init ("dprint_left_margin"), DP_NOTIFY_VAR init ("dprint_notify") ) char (20) static options (constant); get_heading: entry (value, code); call GET (DP_HEAD_VAR); if code = error_table_$oldnamerr then do; if length (value) >= length (xmail_data.actee.person) then do; value = xmail_data.actee.person; code = 0; end; else do; value = ""; code = error_table_$smallarg; end; end; return; get_destination: entry (value, code); call GET (DP_DEST_VAR); if code = error_table_$oldnamerr then do; value = ""; code = 0; end; return; get_request_type: entry (value, code); call GET (DP_RQT_VAR); if code = error_table_$oldnamerr then do; value = ""; code = 0; end; return; get_copies: entry (value, code); call GET (DP_COPIES_VAR); if code = error_table_$oldnamerr then do; value = "1"; /* default = 1 */ code = 0; end; return; get_left_margin: entry (value, code); call GET (DP_LMARGIN_VAR); if code = error_table_$oldnamerr then do; value = "0"; /* default = 0 */ code = 0; end; return; get_notify: entry (value, code); call GET (DP_NOTIFY_VAR); if code = error_table_$oldnamerr then do; value = NO; /* default = no */ code = 0; end; return; /* xmail_print_$set_{heading destination request_type copies left_margin notify} These entries redefine the identified piece of information in the value seg. */ set_heading: entry (value, code); call SET (DP_HEAD_VAR); return; set_destination: entry (value, code); call SET (DP_DEST_VAR); return; set_request_type: entry (value, code); call SET (DP_RQT_VAR); return; set_copies: entry (value, code); call SET (DP_COPIES_VAR); return; set_left_margin: entry (value, code); call SET (DP_LMARGIN_VAR); return; set_notify: entry (value, code); call SET (DP_NOTIFY_VAR); return; SUBMIT: proc (print_dir, print_file, bitcount, desc, dp_args_param, status); /* PARAMETERS */ dcl print_dir char (*), print_file char (*), bitcount fixed bin (24), desc char (*), dp_args_param ptr, status fixed bin (35); /* AUTOMATIC */ dcl user_heading char (64), user_destination char (24), user_request_type char (24), user_copies char (2), user_copies_bin fixed bin, user_lmargin char (2), user_lmargin_bin fixed bin, user_notify char (3), user_notify_bin fixed bin, matched fixed bin (35), dp_args_p ptr, 1 dp_args aligned like dprint_arg based (dp_args_p), 1 default_dp_args aligned like dprint_arg; /* CONSTANTS */ dcl COPIES_LIMIT fixed bin static options (constant) init (30); dcl LEFT_MARGIN_LIMIT fixed bin static options (constant) init (20); /* EXTERNAL STATIC */ dcl error_table_$unimplemented_version fixed bin (35) ext static; /* ENTRIES */ dcl match_star_name_ entry (char (*), char (*), fixed bin (35)), dprint_ entry (char (*), char (*), ptr, fixed bin (35)); /* BUILTINS */ dcl (addr, null, string, unspec) builtin; /* BEGIN */ call get_heading (user_heading, status); if status = 0 then call get_destination (user_destination, status); if status = 0 then call get_request_type (user_request_type, status); if status = 0 then call get_copies (user_copies, status); if status = 0 then call get_left_margin (user_lmargin, status); if status = 0 then call get_notify (user_notify, status); if status ^= 0 then return; /* Convert and check values of copies, lmargin, and notify */ call CONVERT (user_copies, user_copies_bin, status); if status ^= 0 then return; if user_copies_bin > COPIES_LIMIT then do; user_copies = "1"; /* use default */ user_copies_bin = 1; end; call CONVERT (user_lmargin, user_lmargin_bin, status); if status ^= 0 then return; if user_lmargin_bin > LEFT_MARGIN_LIMIT then do; user_lmargin = "0"; /* use default */ user_lmargin_bin = 0; end; if user_notify = YES then user_notify_bin = 1; else user_notify_bin = 0; /* use default */ if dp_args_param = null then do; dp_args_p = addr (default_dp_args); unspec (dp_args) = ""b; dp_args.version = dprint_arg_version_9; dp_args.delete = 0; string (dp_args.carriage_control) = ""b; dp_args.line_lth = -1; dp_args.page_lth = -1; dp_args.top_label = ""; dp_args.bottom_label = ""; dp_args.form_name = ""; dp_args.chan_stop_path = ""; end; else do; dp_args_p = dp_args_param; if dp_args.version ^= dprint_arg_version_9 then do; status = error_table_$unimplemented_version; return; end; end; if xmail_data.confirm_print then call CONFIRM_FIRST; dp_args.queue = 0; /* default */ dp_args.pt_pch = 1; /* print */ dp_args.output_module = 1; /* print */ dp_args.bit_count = bitcount; dp_args.heading = user_heading; dp_args.destination = user_destination; dp_args.request_type = user_request_type; dp_args.defer_until_process_termination = 0; dp_args.copies = user_copies_bin; dp_args.lmargin = user_lmargin_bin; dp_args.notify = user_notify_bin; call match_star_name_ (print_file, string (CREATED_FILE_FORMAT), matched); if matched = 0 then dp_args.delete = 1; call dprint_ (print_dir, print_file, dp_args_p, status); if xmail_data.confirm_print then call ioa_ ("Print request has been submitted."); else do; if user_request_type = "" then user_request_type = "system default printer"; if user_destination = "" then user_destination = "not specified"; call ioa_ ("Request for printed copy has been submitted to printer: ^a^/Printed copy to be delivered to: ""^a"". Location: ""^a""", user_request_type, user_heading, user_destination); end; SUBMIT_EXIT: return; CONFIRM_FIRST: proc; /* within SUBMIT */ /* AUTOMATIC */ dcl cf_first_time bit (1) aligned; /*first time flag*/ /* BEGIN */ cf_first_time = "1"b; do while ("1"b); call ioa_ (" Header: ^a", user_heading); call ioa_ (" Destination: ^[not specified^;^a^]", user_destination = "", user_destination); call ioa_ (" Station: ^[system default printer^;^a^]", user_request_type= "", user_request_type); call ioa_ (" Left Margin: ^a", user_lmargin); call ioa_ (" Copies: ^a", user_copies); call ioa_ (" Notify: ^a^/", user_notify); if cf_first_time then do; call xmail_get_str_$yes_no ("Do you wish to temporarily change any options before printing?", yes_sw); cf_first_time = "0"b; end; else call xmail_get_str_$yes_no ("Do you wish to make any more changes?", yes_sw); if ^yes_sw then go to CONFIRM_EXIT; call TEMP_CHANGE; end; CONFIRM_EXIT: return; end CONFIRM_FIRST; TEMP_CHANGE: proc (); /* Produces a dynamic menu in the lower window providing options to temporarily change the printing options from the personalization menu */ /* CONSTANTS */ dcl TEMP_CHANGE_CHOICES dim (6) char (26) int static options (constant)init ("Set Header", "Set Destination", "Set Station", "Set Left Margin", "Set Number of Copies", "Notify After Printing") aligned var; /* AUTOMATIC */ dcl tc_choice fixed bin; dcl tc_code fixed bin (35); dcl tc_selected_done bit (1) aligned; dcl temp_change_menup ptr init (null) int static; /* ENTRIES */ dcl get_system_free_area_ entry () returns (ptr); dcl xmail_dyn_menu_$create_w_trailer entry ((*) char (*) aligned, char (*), ptr, ptr, ptr, fixed bin (35)); dcl xmail_error_$no_code entry () options (variable); dcl xmail_get_dyn_choice_$trailer entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); dcl xmail_sw_$update_usage entry (char (*)); dcl xmail_sw_$redisplay entry (); /* EXTERNAL STATIC */ dcl iox_$user_output ptr ext static; /* BEGIN */ if temp_change_menup = null then do; call xmail_dyn_menu_$create_w_trailer ((TEMP_CHANGE_CHOICES), "", temp_change_menup, null, get_system_free_area_ (), tc_code); if tc_code ^= 0 then call xmail_error_$no_code (tc_code, NAME, "q", "Unable to create temporary print change menu.^/ This is an internal programming error."); end; do while ("1"b); call xmail_sw_$update_usage (""); call xmail_sw_$redisplay (); call window_$clear_window (iox_$user_output, (0)); call xmail_get_dyn_choice_$trailer (temp_change_menup, tc_choice, tc_selected_done, tc_code); if tc_selected_done then go to TEMP_CHANGE_EXIT; if tc_code ^= 0 then call xmail_error_$no_code (tc_code, NAME, "q", "Unable to display temporary print change menu.^/ This is an internal programming error."); call window_$clear_window (iox_$user_output, (0)); call PERFORM_CHANGE (tc_choice); call xmail_get_str_$yes_no ("More changes?", yes_sw); if ^yes_sw then go to TEMP_CHANGE_EXIT; end; TEMP_CHANGE_EXIT: call window_$clear_window (iox_$user_output, (0)); return; PERFORM_CHANGE: proc (opt); /* PARAMETERS */ dcl opt fixed bin parameter;/* input */ /* AUTOMATIC */ dcl name char (26) varying; dcl new_value char (200) varying; dcl new_value_bin fixed bin; /* ENTRIES */ dcl xmail_Review_Defaults_$get_new_copies entry (char (*), char (*) var, fixed bin); dcl xmail_Review_Defaults_$get_new_destination entry (char (*), char (*) var); dcl xmail_Review_Defaults_$get_new_header entry (char (*), char (*) var); dcl xmail_Review_Defaults_$get_new_margin entry (char (*), char (*) var, fixed bin); dcl xmail_Review_Defaults_$get_new_notify entry (char (*), char (*), char(*) var); dcl xmail_Review_Defaults_$get_new_station entry (char (*), char (*) var); /* BEGIN PERFORM_CHANGE */ name = TEMP_CHANGE_CHOICES (opt); /* include name of option*/ go to OPT (opt); OPT (1): call xmail_Review_Defaults_$get_new_header (user_heading, new_value); if length (new_value) ^= 0 then user_heading = new_value; go to OPT_EXIT; OPT (2): call xmail_Review_Defaults_$get_new_destination (user_destination, new_value); if length (new_value) ^= 0 then user_destination = new_value; go to OPT_EXIT; OPT (3): call xmail_Review_Defaults_$get_new_station (user_request_type, new_value); if new_value = "default" then user_request_type = ""; /* null for default*/ else if length (new_value) ^= 0 then user_request_type = new_value; go to OPT_EXIT; OPT (4): call xmail_Review_Defaults_$get_new_margin (user_lmargin, new_value, new_value_bin); if length (new_value) ^= 0 then do; user_lmargin = new_value; /* for message */ user_lmargin_bin = new_value_bin; /* for dprint_ */ end; go to OPT_EXIT; OPT (5): call xmail_Review_Defaults_$get_new_copies (user_copies, new_value, new_value_bin); if length (new_value) ^= 0 then do; user_copies = new_value; /* for message */ user_copies_bin = new_value_bin; /* for dprint_ */ end; go to OPT_EXIT; OPT (6): call xmail_Review_Defaults_$get_new_notify ((name), user_notify, new_value); if length (new_value) ^= 0 then do; user_notify = new_value; /* for message */ if new_value = YES then user_notify_bin = 1; /* for dprint_ */ else user_notify_bin = 0; end; go to OPT_EXIT; OPT_EXIT: return; end PERFORM_CHANGE; end TEMP_CHANGE; end SUBMIT; CONVERT: proc (c_value_char, c_value_bin, c_status); /* Converts a character value to a binary value so it can be tested against limits and inserted in the dprint_ structure. */ /* PARAMETERS */ dcl c_value_char char (*); /* input */ dcl c_value_bin fixed bin; /* output */ dcl c_status fixed bin (35); /* output */ /* CONDITIONS */ dcl (conversion, size) condition; /* BEGIN */ c_status = 0; on conversion, size c_status = error_table_$bad_conversion; c_value_bin = convert (c_value_bin, c_value_char); revert conversion, size; return; end CONVERT; GET: proc (name); dcl name char (20); dcl result char (64) varying; dcl xmail_value_$get entry (char (*), char (*) var, fixed bin (35)), xmail_value_$set entry (char (*), char (*) var, char (*) var, fixed bin (35)); call xmail_value_$get (name, result, code); if code = 0 then do; if length (value) >= length (result) then value = result; else do; value = ""; code = error_table_$smallarg; end; end; return; SET: entry (name); call xmail_value_$set (name, rtrim (value), result, code); return; end GET; end xmail_print_;  xmail_process_user_msg_.pl1 09/02/88 0759.6r w 09/02/88 0747.6 131553 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-25,Blair), approve(86-07-15,MCR7447), audit(86-07-18,LJAdams), install(86-07-21,MR12.0-1100): Accept the old format of "Cc:" so that users can read their deferred messages which were created before the format changed to "cc:" for copies. Error #119. 2) change(86-06-25,Blair), approve(86-07-15,MCR7447), audit(86-07-18,LJAdams), install(86-07-21,MR12.0-1100): When passing arguments to the mail_system routines which build the message, precede the keywords used to delimit the contents of the header fields with a NL to make sure that keywords which are part of the text are not used incorrectly. TR 20269. 3) change(87-08-10,Blair), approve(87-12-10,MCR7818), audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013): Add capability to parse a Reply-To field in a message header and process the supplied value. END HISTORY COMMENTS */ xmail_process_user_msg_: procedure (); /* BEGIN DESCRIPTION function: This proc is called by xmail_prepare_msg_ to extract the "subject text and the "message" text from the msg prepared by the user via emacs. It uses the mlsys_utils_$parse_address_list_text proc to establish the primary and secondary (if any) recipients address structure lists. Note that this procedure assumes that there are no syntax errors in the user specified list of addresses and/or address lists since the emacs extention does this as well as determining that for every address specified there is a corresponding mailbox. history: 81-07-03 Written by R. Ignagni, format: style1. 83-07-13 DJ Schimke: Modified to use new mail_system calls and version 2 mailboxes. 84-08-07 JG Backs: Modified for the addition of blind carbon copies (bcc) 84-11-08 JG Backs: Removed the input parameter P_caller, which was not used anywhere in module, but was passed to xmail_send_msg_. Since it also was not used there, it was removed in both places, changing the call and declaration statement of module xmail_send_msg_ to eliminate the parameter. These changes also required respective changes to xmail_prepare_msg_ and xmail_send_stored_msg_, which are the only two modules calling this module. Audit change. 84-11-09 JG Backs: Deleted the spaces within the quotes of "To:", "cc:", and "bcc:" because they were not needed and were inconsistant within and across modules. Audit change. END DESCRIPTION */ /* CONDITIONS */ dcl (quit, cleanup) condition; /* STATIC */ dcl wrong_format char (31) static options (constant) init ("Message not in expected format."); dcl error_message char (67) static options (constant) init ("Sending of message not completed, due to an internal program error."); dcl WHITE_SPACE char (4) aligned static options (constant) init (" "); /* HT VT NL */ dcl WHITE_SPACE_COMMA char (6) aligned static options (constant) init (" ,"); /* HT VT NL comma */ dcl NAME char (23) static options (constant) init ("xmail_process_user_msg_"); dcl NL char (1) int static options (constant) init (" "); dcl stop char (1) static options (constant) init ("q"); /* AUTOMATIC */ dcl bit_count fixed bin (24); dcl code fixed bin (35); dcl copy_format char (3); dcl follows_copy char (8); dcl new_style bit (1) aligned; dcl no_chars fixed bin (21); dcl old_style bit (1) aligned; dcl start_of_text fixed bin; dcl 1 auto_message_body_section_parameter automatic like message_body_section_parameter; dcl 1 auto_parse_text_options automatic like parse_text_options; /* BASED */ dcl based_string char (no_chars) based (send_mail_info.emacs_seg_ptr); dcl based_array (no_chars) char (1) based (send_mail_info.emacs_seg_ptr); /* ENTRIES */ dcl xmail_send_msg_ entry (); /* no parameter */ dcl xmail_error_$no_code entry options (variable); dcl xmail_error_$code_last entry options (variable); dcl xmail_window_manager_$reconnect entry (); dcl mail_system_$add_body_section entry (ptr, ptr, fixed bin, fixed bin (35)); dcl mail_system_$create_message entry (char (8), ptr, fixed bin (35)); dcl mail_system_$free_address_list entry (ptr, fixed bin (35)); dcl mail_system_$free_message entry (ptr, fixed bin (35)); dcl mail_system_$replace_bcc entry (ptr, ptr, fixed bin (35)); dcl mail_system_$replace_cc entry (ptr, ptr, fixed bin (35)); dcl mail_system_$replace_reply_to entry (ptr, ptr, fixed bin (35)); dcl mail_system_$replace_subject entry (ptr, char (*), fixed bin (35)); dcl mail_system_$replace_to entry (ptr, ptr, fixed bin (35)); dcl mlsys_utils_$parse_address_list_text entry (char (*), ptr, char (8), ptr, ptr, fixed bin (35)); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl ioa_ entry options (variable); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); /* BUILTIN */ dcl (addr, after, before, divide, index, length, ltrim, null, rtrim, substr) builtin; /* INCLUDE FILES */ %include mlsys_message; %page; %include xmail_data; %page; %include window_dcls; %page; %include xmail_send_mail; %page; %include mlsys_address_list; %page; %include mlsys_parse_txt_options; /* BEGIN */ /* Set up quit and cleanup conditions */ START: parse_text_error_list_ptr, message_ptr = null (); on condition (cleanup) call CLEAN_UP; on condition (quit) begin; call xmail_window_manager_$reconnect (); call ioa_ ("Sending message terminated."); call CLEAN_UP; go to exit; end; call hcs_$status_mins (send_mail_info.emacs_seg_ptr, 1, bit_count, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message); /* Get number of chars in seg */ if bit_count = 0 /* The user "quit" while in emacs */ then do; call ioa_ ("Sending message terminated."); call CLEAN_UP; return; end; no_chars = divide (bit_count, 9, 17, 0); /* Extract the "Subject", "To", "cc", and "bcc" fields from the segment created by Emacs */ old_style, new_style = "0"b; if index (based_string, "Cc:") > 0 then do; old_style = "1"b; copy_format = "Cc:"; follows_copy = "Message:"; end; if index (based_string, "cc:") > 0 then do; new_style = "1"b; copy_format = "cc:"; follows_copy = "bcc:"; end; if (^(old_style | new_style) | (index (based_string, "Subject:") = 0) | (index (based_string, "To:") = 0) | /* (index (based_string, "cc:") = 0) | (index (based_string, "bcc:") = 0) | replaced by old_style new_style */ (index (based_string, "Message:") = 0)) then call xmail_error_$no_code (code, NAME, stop, "^a Sending terminated.", wrong_format); if new_style & (index (based_string, "bcc:") = 0) then call xmail_error_$no_code (code, NAME, stop, "^a Sending terminated.", wrong_format); if rtrim (after (based_string, "Message:"), WHITE_SPACE) = "" then call xmail_error_$no_code (code, NAME, "i", "No message text entered. Sending terminated."); call mail_system_$create_message (MESSAGE_VERSION_2, send_mail_info.new_msg_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message); /* Supply "subject" for the new message */ call mail_system_$replace_subject (send_mail_info.new_msg_ptr, (after (before (based_string, NL || "Reply-To:"), "Subject:"))|| NL, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message); /* Supply the "message" field for the new message */ message_body_section_ptr = addr (auto_message_body_section_parameter.section); auto_message_body_section_parameter.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; message_preformatted_body_section.header.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_preformatted_body_section.header.section_n_lines = -1; start_of_text = index (based_string, NL || "Message:") + length ("Message:") + 1; message_preformatted_body_section.text_ptr = addr (based_array (start_of_text)); message_preformatted_body_section.text_lth = length (substr (rtrim (based_string), start_of_text)); call mail_system_$add_body_section (send_mail_info.new_msg_ptr, addr (auto_message_body_section_parameter), 1, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, stop, "^a", error_message); /* Convert text to address lists for To:, bcc:, and cc: fields */ send_mail_info.to_list_ptr, send_mail_info.reply_to_list_ptr, send_mail_info.cc_list_ptr, send_mail_info.bcc_list_ptr = null (); auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1; auto_parse_text_options.area_ptr = null; auto_parse_text_options.flags.list_errors = "0"b; auto_parse_text_options.flags.validate_addresses = "0"b; auto_parse_text_options.flags.include_invalid_addresses = "0"b; auto_parse_text_options.flags.mbz = "0"b; if rtrim (after (before (based_string, NL || "To:"), NL || "Reply-To:"), WHITE_SPACE_COMMA) || NL = "" then goto PROCESS_TO; else do; call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "To:"), NL || "Reply-To:") || NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.reply_to_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then call xmail_error_$code_last ( code, NAME, stop, "^a^/", error_message); call mail_system_$replace_reply_to (send_mail_info.new_msg_ptr, send_mail_info.reply_to_list_ptr, code); if code ^= 0 then call xmail_error_$code_last ( code, NAME, stop, "^a^/", error_message); end; PROCESS_TO: if rtrim (after (before (based_string, NL || copy_format), NL || "To:"), WHITE_SPACE_COMMA) || NL = "" then call xmail_error_$no_code (code, NAME, "i", "You did not enter any recipients. Sending terminated."); call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || copy_format),NL || "To:") || NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.to_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message); call mail_system_$replace_to (send_mail_info.new_msg_ptr, send_mail_info.to_list_ptr, code); if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message); if ltrim (rtrim (after (before (based_string,NL || rtrim(follows_copy)), NL ||copy_format), WHITE_SPACE_COMMA), WHITE_SPACE_COMMA) || NL ^= "" then call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || rtrim(follows_copy)), NL || copy_format)|| NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.cc_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message); if send_mail_info.cc_list_ptr ^= null then do; call mail_system_$replace_cc (send_mail_info.new_msg_ptr, send_mail_info.cc_list_ptr, code); if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message); end; /* Add bcc handling */ if new_style then if ltrim (rtrim (after (before (based_string, NL || "Message:"), NL || "bcc:"), WHITE_SPACE_COMMA), WHITE_SPACE_COMMA) || NL ^= "" then call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "Message:"), NL || "bcc:") || NL, WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, send_mail_info.bcc_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message); if send_mail_info.bcc_list_ptr ^= null then do; call mail_system_$replace_bcc (send_mail_info.new_msg_ptr, send_mail_info.bcc_list_ptr, code); if code ^= 0 then call xmail_error_$code_last (code, NAME, stop, "^a^/", error_message); end; send_mail_info.msg_exists = "1"b; if parse_text_error_list_ptr ^= null () then do; free parse_text_error_list; parse_text_error_list_ptr = null (); end; call xmail_send_msg_ (); /* no parameter */ return; exit: return; %page; /* INTERNAL PROCEDURES */ CLEAN_UP: proc (); if send_mail_info.emacs_seg_ptr ^= null () then call delete_$ptr (send_mail_info.emacs_seg_ptr, "100101"b, NAME, code); if send_mail_info.new_msg_ptr ^= null () then call mail_system_$free_message (send_mail_info.new_msg_ptr, code); if code ^= 0 then send_mail_info.to_list_ptr = null (); if send_mail_info.to_list_ptr ^= null () then call mail_system_$free_address_list (send_mail_info.to_list_ptr, code); if code ^= 0 then send_mail_info.reply_to_list_ptr = null (); if send_mail_info.reply_to_list_ptr ^= null () then call mail_system_$free_address_list (send_mail_info.reply_to_list_ptr, code); if code ^= 0 then send_mail_info.cc_list_ptr = null (); if send_mail_info.cc_list_ptr ^= null () then call mail_system_$free_address_list (send_mail_info.cc_list_ptr, code); if code ^= 0 then send_mail_info.bcc_list_ptr = null (); if send_mail_info.bcc_list_ptr ^= null () then call mail_system_$free_address_list (send_mail_info.bcc_list_ptr, code); send_mail_info.emacs_seg_ptr = null (); send_mail_info.new_msg_ptr = null (); send_mail_info.msg_exists = "0"b; send_mail_info.emacs_seg_pathname = ""; return; end CLEAN_UP; end xmail_process_user_msg_;  xmail_rebuild_value_seg_.pl1 09/02/88 0759.6rew 09/02/88 0736.1 106587 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-02-11,Blair), approve(86-02-26,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): Written by J. Blair. 2) change(87-04-17,Blair), approve(87-04-22,MCR7683), audit(87-05-15,RBarstad), install(87-05-26,MR12.1-1037): Enable the cp_escape for when we have to query the user for continuing when we rebuild the value_seg. TR 20776. 3) change(88-06-28,Blair), approve(88-07-27,MCR7959), audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098): Add new entry point (copy) for when we have read access to the mlsys value seg, but can't write to it. END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This program allows the xmail value segment to be rebuilt when one of the value names */ /* contains invalid data or the segment appears to be damaged in some way. This routine */ /* is called from xmail_value_. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ xmail_rebuild_value_seg_: proc (xrvs_value_ptr, xrvs_code); /* BEGIN */ on cleanup begin; call CLEANUP; end; /* Get rid of the bad value segment */ xrvs_value_seg_ptr = xrvs_value_ptr; call terminate_file_ (xrvs_value_seg_ptr, bc, TERM_FILE_DELETE, code); if code = 0 & xrvs_value_seg_ptr ^= null then do; user_name = xmail_data.person; call user_info_$homedir (homedir); mlsys_dir_entry = user_name || MLSYS_DIR_SUFFIX; value_dir = rtrim (homedir) || ">" || mlsys_dir_entry; seg_type = 0; /* permanent value seg */ call ioa_ ("^/ The value segment which contains your personalization options"); call ioa_ (" contains invalid data or cannot be accessed for some reason."); call ioa_ (" A new value segment will be built in your mlsys directory."); call ioa_ (" You may reset the personalization options by selecting"); call ioa_ (" ""Personalize Exec Mail"" from the main menu.^/"); end; else do; value_dir = get_pdir_ (); seg_type = 1; /* temporary value seg */ call ioa_ ("^/ The value segment which contains your personalization options"); call ioa_ (" cannot be altered or deleted. A temporary value segment with"); call ioa_ (" default personalization option values has been created for you"); call ioa_ (" in your process_dir. These options may be changed, but the new"); call ioa_ (" values will only have effect for the duration of your process.^/"); end; call PRESS_TO_CONTINUE; xrvs_value_seg_ptr = null; call initiate_file_$create (value_dir, (VALUE_SEG_NAME), REW_ACCESS, xrvs_value_seg_ptr, created_sw, bc, code); call MAIN; return; copy: entry (P_value_seg_ptr, P_code); %include copy_options; %include copy_flags; dcl P_value_seg_ptr ptr; dcl P_code fixed bin (35) parm; dcl 01 my_copy_options like copy_options; dcl fs_util_$copy entry (ptr, fixed bin(35)); value_dir = get_pdir_(); xmail_data.value_seg_pathname = value_dir; call initiate_file_$create (value_dir, (VALUE_SEG_NAME), REW_ACCESS, xrvs_value_seg_ptr, created_sw, bc, code); if code = 0 then if ^created_sw then call MAIN; else do; my_copy_options.version = COPY_OPTIONS_VERSION_1; user_name = xmail_data.person; call user_info_$homedir (homedir); mlsys_dir_entry = user_name || MLSYS_DIR_SUFFIX; value_dir = rtrim (homedir) || ">" || mlsys_dir_entry; my_copy_options.source_dir = value_dir ; my_copy_options.source_name = VALUE_SEG_NAME; my_copy_options.target_dir = get_pdir_(); my_copy_options.target_name = VALUE_SEG_NAME; my_copy_options.no_name_dup = "1"b; my_copy_options.raw = "0"b; my_copy_options.force = "0"b; my_copy_options.delete = "0"b; my_copy_options.flags.mbz = "0"b; my_copy_options.copy_items = "0"b; my_copy_options.copy_items.update = "1"b; call fs_util_$copy (addr(my_copy_options), code); if code = 0 then do; call ioa_ ("^/ The value segment which contains your personalization options"); call ioa_ (" cannot be altered or deleted. A temporary value segment with"); call ioa_ (" copies of your personalization option values has been created for"); call ioa_ (" you in your process_dir. These options may be changed, but the"); call ioa_ (" new values will only have effect for the duration of your process.^/"); call PRESS_TO_CONTINUE; P_value_seg_ptr = xrvs_value_seg_ptr; end; end; P_code = code; return; MAIN: proc (); /* Create a new value_segment. Put it in the process_dir if there was some reason you couldn't get rid of the old one, otherwise it goes in the mlsys_dir. */ if code = 0 & created_sw then call value_$init_seg (xrvs_value_seg_ptr, seg_type, null, 0, code); if code ^= 0 then goto XMAIL_REBUILD_VALUE_SEG_EXIT; else xmail_data.value_seg_pathname = value_dir; /* Set all the default values in the value segment if we have a new one*/ if created_sw then do; call SET_DEFAULT (xrvs_value_seg_ptr, VERSION, (xmail_version)); call SET_DEFAULT (xrvs_value_seg_ptr, SAVE_MESSAGE, (YES)); call SET_DEFAULT (xrvs_value_seg_ptr, SAVE_MAILBOX, (ASK)); call SET_DEFAULT (xrvs_value_seg_ptr, "lifetime_first_invocation", (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, ACKNOWLEDGE, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, LISTS_AS_MENUS, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, INTERACTIVE_MSGS, (YES)); call SET_DEFAULT (xrvs_value_seg_ptr, ALWAYS_ESCAPE, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, MULTICS_MODE, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, REMOVE_MENUS, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, CONFIRM_PRINT, (YES)); call SET_DEFAULT (xrvs_value_seg_ptr, INCLUDE_ORIGINAL, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, FILE_ORIGINAL, (NO)); call SET_DEFAULT (xrvs_value_seg_ptr, ORIGINAL_IN_WINDOW, (YES)); end; xrvs_code = 0; return; XMAIL_REBUILD_VALUE_SEG_EXIT: call CLEANUP; xrvs_code = 1; return; SET_DEFAULT: proc (sd_value_seg_ptr, sd_value_name, sd_default); /* PARAMETERS */ dcl sd_value_name char (*); dcl sd_default char (*); dcl sd_value_seg_ptr ptr; dcl PERMANENT init ("01"b) bit (36) aligned static options (constant); /* BEGIN */ call value_$set (sd_value_seg_ptr, PERMANENT, sd_value_name, (sd_default), answer_yn, code); if code ^= 0 then goto XMAIL_REBUILD_VALUE_SEG_EXIT; end SET_DEFAULT; end MAIN; PRESS_TO_CONTINUE: proc; dcl prompt char (46) init (" Press to continue") int static options (constant); dcl 1 auto_query_info like query_info; dcl been_thru_this_before bit (1) aligned; dcl line char (80) var; dcl iox_$user_output ptr ext static; dcl command_query_ entry() options(variable); dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); dcl ENABLE_ESCAPE bit (2) aligned init ("11"b) int static options (constant); auto_query_info.version = query_info_version_6; auto_query_info.switches.yes_or_no_sw = "0"b; auto_query_info.switches.suppress_name_sw = "1"b; auto_query_info.switches.cp_escape_control = ENABLE_ESCAPE; auto_query_info.switches.suppress_spacing = "1"b; auto_query_info.switches.literal_sw = "0"b; auto_query_info.switches.prompt_after_explanation = "0"b; auto_query_info.switches.padding = "0"b; auto_query_info.status_code = 0; auto_query_info.query_code = 0; auto_query_info.question_iocbp = null (); /* default: user_i/o */ auto_query_info.answer_iocbp = null (); /* default: user_input */ auto_query_info.repeat_time = 0; /* don't repeat */ auto_query_info.explanation_ptr = null (); auto_query_info.explanation_len = 0; been_thru_this_before = "0"b; do while ("1"b); call iox_$control (iox_$user_output, "reset_more", null, (0)); /* ignore code */ call command_query_ (addr (auto_query_info), line, "", "^[^/^]^a^2x", been_thru_this_before, prompt); been_thru_this_before = "1"b; if line = "" then goto EXIT_PRESS_TO_CONTINUE; end; EXIT_PRESS_TO_CONTINUE: return; end PRESS_TO_CONTINUE; CLEANUP: proc (); if xrvs_value_seg_ptr ^= null then do; call terminate_file_ (xrvs_value_seg_ptr, bc, TERM_FILE_DELETE, code); xrvs_value_seg_ptr = null; end; return; end CLEANUP; %include query_info; %include terminate_file; %include access_mode_values; %include xmail_data; /* PARAMETERS */ dcl xrvs_value_ptr ptr; dcl xrvs_code fixed bin (35); /* AUTOMATIC */ dcl answer_yn char (3) var; dcl bc fixed bin (24); dcl code fixed bin (35); dcl created_sw bit (1) aligned; dcl homedir char (168); dcl mlsys_dir_entry char (32); dcl seg_type fixed bin; dcl user_name char (35) var; dcl value_dir char (168); dcl xrvs_value_seg_ptr ptr; /* ENTRIES */ dcl get_pdir_ entry () returns (char (168)); dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl user_info_$homedir entry (char (*)); dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35)); dcl value_$set entry() options(variable); /* BUILTINS */ dcl (addr, null, rtrim) builtin; /* CONDITIONS */ dcl cleanup condition; /* CONSTANTS */ dcl ASK char (3) init ("ask") int static options (constant); dcl MLSYS_DIR_SUFFIX char (6) init (".mlsys") int static options (constant); dcl NO char (2) init ("no") int static options (constant); dcl VALUE_SEG_NAME init ("xmail_data.value") char (32) var int static options (constant); dcl VERSION init ("version") char (7) int static options (constant); dcl YES char (3) init ("yes") int static options (constant); dcl ( /*** names of personalization options ***/ ACKNOWLEDGE char (14) init ("acknowledge_yn"), ALWAYS_ESCAPE char (21) init ("always_escape_keys_yn"), CONFIRM_PRINT char (19) init ("confirm_print_yn"), FILE_ORIGINAL char (16) init ("file_original_yn"), INCLUDE_ORIGINAL char (19) init ("include_original_yn"), ORIGINAL_IN_WINDOW char (21) init ("original_up_window_yn"), INTERACTIVE_MSGS char (19) init ("interactive_msgs_yn"), LISTS_AS_MENUS char (17) init ("lists_as_menus_yn"), MULTICS_MODE char (15) init ("multics_mode_yn"), /* OUTGOING_SV_BOX char (32) init ("outgoing.sv.mbx"), historic entry only */ REMOVE_MENUS char (15) init ("remove_menus_yn"), SAVE_MAILBOX char (15) init ("save_mailfile"), SAVE_MESSAGE char (15) init ("save_message_yn") ) static options (constant); end xmail_rebuild_value_seg_;  xmail_redisplay_.pl1 12/02/84 1109.7rew 12/02/84 1015.0 19242 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ xmail_redisplay_: proc (); /* Author unknown 83-09-14 DJ Schimke: Changed the call to iox_$control clear_window on video_data_$user_terminal to a window_$clear_window call on xmail_data.moved_user_io. This fixes TR 12524 which complains that xmail clears the entire screen rather than only the window it is using. 84-06-22 DJ Schimke: Changed xmail to resize user_io rather than syning user_io to xmail_bottom_window. This allows user specified keybindings and more prompts to be supported from within xmail. The call to clear the moved_user_io window was changed to individual calls to clear the status, menu, and bottom xmail windows. */ /* Entries */ dcl xmail_sw_$redisplay entry (); dcl window_$clear_window entry (ptr, fixed bin (35)); /* Condition */ dcl xmail_redisplay_menu condition; all: entry (); call window_$clear_window (xmail_windows.status.iocb, (0)); /* ignore code */ call window_$clear_window (xmail_windows.menu.iocb, (0)); /* ignore code */ call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */ call xmail_sw_$redisplay (); signal xmail_redisplay_menu; call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */ return; /* all */ status_window: entry (); call xmail_sw_$redisplay (); return; /* status_window */ menu: entry (); signal xmail_redisplay_menu; return; /* menu */ bottom_wndw: entry (); call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore code */ return; /* bottom_wndw */ %page; %include xmail_windows; end xmail_redisplay_;  xmail_reply_msg_.pl1 10/06/92 0031.0r w 10/06/92 0026.4 512838 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1992 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-07,Blair), approve(86-02-26,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): 85-04-01 JG Backs: Deleted the constant ASK because it was added to the include file xmail_responses.incl.pl1 and resulted in a compiler warning. 85-05-07 JG Backs: Add an internal procedure to handle the new personalize Include Original in Reply option. 2) change(86-01-07,Blair), approve(86-02-26,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): Move code to indicate reply was completed to before the code that asks if the message should be saved. Add code to file the original before filing the reply when indicated. Allow for suppressing the display of the original message in the upper window when indicated. 3) change(86-01-17,Blair), approve(86-02-26,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): Check the delete_def_reply flag in CLEAN_UP to make sure that deleted deferred replies get deleted on cleanup. TR 18152. 4) change(86-01-28,Blair), approve(86-02-26,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): Add handler for reissue_query condition so that any question can be reissued after the user has hit break in response and then indicated that he wishes to continue. TRs 18711 18974. 5) change(86-10-15,Blair), approve(86-10-15,MCR7564), audit(86-10-28,RBarstad), install(86-10-29,MR12.0-1201): Make replies which include the original message display the message envelope so that the "Sender:" field will be displayed. Fixes error_list 129. 6) change(87-01-21,Blair), approve(87-02-05,MCR7618), audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025): Grow the reply_msg buffer as necessary since 5000 characters isn't isn't always big enough. Error_list 136. 7) change(87-02-13,Blair), approve(87-02-13,MCR7618), audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025): Set the static variable reply_request in xmail_data so that we'll be able to know that a reply was being processed when a disconnect occured. Error list #114. 8) change(87-11-06,Blair), approve(87-12-10,MCR7818), audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013): Move heaven and earth to add the "Reply-To:" field to deferred msgs so that when we get to the emacs editor, the user can edit this field. Rearrange code to query in the correct sequence (ask if we are to use deferred before we decide whether or not to include the original. Also make sure we don't delete the deferred reply when we defer a reply that was originally deferred. 9) change(92-09-10,Zimmerman), approve(92-09-10,MCR8256), audit(92-09-15,Vu), install(92-10-06,MR12.5-1022): Fix bug with "Reply-To:" field. END HISTORY COMMENTS */ xmail_reply_msg_: procedure (P_mailbox_ptr, P_curr_msgs_ptr); /* BEGIN DESCRIPTION function: This proc is invoked as a consequence of the user selecting the Reply option on the Process Incoming Mail or Process Filed Mail nemus. The being-replied-to message is displayed on the upper portion of the screen. The proc calls emacs so that the reply text can be composed and also to permit the user to modify the default recipient list. If the user has so specified the message will be saved in the "outgoing" mbx. The reply will be acknowledged if the user has so specified. history: 81-07-11 Written by R. Ignagni, extensively updated in Nov 1981 83-07-18 DJ Schimke: Modified to use new mail_system calls and version 2 mailboxes. 83-09-15 DJ Schimke: Increased the initial size of the based array from 600 characters to 5000 characters. The array wasn't always big enough for very large to or cc fields. 5000 should be plenty. phx13809 83-09-21 DJ Schimke: Modified to query the user before creating a new mail file to save a copy of the reply. This is only in effect when save-outgoing is set to "ask". phx13779 83-10-12 DJ Schimke: Replaced the call to mail_system_$save_message and associated code with a call to xmail_file_msgs_$single_msg; 83-10-26 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a call to xmail_window_manager_$quit_handler so the quit condition handler can special-case the reconnect condition which should NOT interrupt processing after the quit. phx 13227 This entry also prompts when not at a reconnect condition so that unintentionally hitting the BREAK won't throw away any pending work. phx 13018 83-11-22 DJ Schimke: Removed the test for cc string ^= "" before parsing and replacing the cc_list_ptr in the reply message. This test didn't allow the user to delete the cc list even when xmail claimed to have deleted it. 83-11-23 DJ Schimke: Added support for the new personalization option "Outgoing Savefile" which allows selection of where to file save messages. This also solves the discrepancy between setting "Save Outgoing messages" to "yes" and never having set "Save Outgoing messages". 83-12-07 DJ Schimke: Cleaned up the reporting of delivery results by calling mlsys_utils_$print_delivery_results_ and mlsys_utils_$print_address_field for displaying the failure/success of sending. This module still needs recovery code to allow the sender to correct the bad addresses and continue. Deleted unused variable transition_state. 83-12-08 DJ Schimke: Added simple flag to prevent the call to mlsys_util_$free_delivery_results until the call to send the msg has been made. Otherwise, this cleanup will get errors referencing invalid pointers. 83-02-20 DJ Schimke: Modified the cleanup code so recipients_info is only freed by the CLEANUP procedure instead of the MESSAGE_CLEAN_UP procedure. This fixes a problem referencing recipients_info when replying to more than one message (curr_msgs.count > 1). 84-08-08 JG Backs: Modified for the addition of blind carbon copies (bcc). 84-11-08 JG Backs: Deleted the spaces within the quotes of "To:", "cc:" and "bcc:" when used in the calls to mlsys_utils_$parse_address_list_text. The spaces were not needed and were inconsistant across modules. Audit change. END DESCRIPTION */ /* PARAMETERS */ dcl P_mailbox_ptr ptr parameter; dcl P_curr_msgs_ptr ptr parameter; /* CONDITIONS */ dcl (quit, cleanup, reissue_query) condition; /* EXTERNAL STATIC */ dcl error_table_$bad_segment ext static fixed bin (35); dcl error_table_$namedup ext static fixed bin (35); dcl error_table_$segknown ext static fixed bin (35); dcl error_table_$smallarg ext static fixed bin (35); dcl iox_$user_output ptr external static; dcl mlsys_et_$no_a_permission static ext fixed bin (35); /* CONSTANTS */ dcl ALLOW_SELECTION bit (1) aligned static options (constant) init ("1"b); dcl ACKNOWLEDGE char (14) static options (constant) init ("acknowledge_yn"); dcl CONTINUE char (1) static options (constant) init ("c"); dcl BITS_PER_CHAR fixed bin static options (constant) init (9); dcl DEFAULT_WIDTH fixed bin static options (constant) init (72); dcl DELETE_SEG_FORCE bit (6) static options (constant) init ("100100"b); dcl DELETE_SEG_FORCE_CHASE bit (6) static options (constant) init ("100101"b); dcl EMACS_EXT char (21) options (constant) init ("xmail_emacs_ext_main_") int static; dcl ENTRY_NAME entry variable init (xmail_reply_msg_); dcl ERROR_MESSAGE char (69) static options (constant) init ("Reply to message no. ^d terminated, due to an internal program error."); dcl ERRORS_ONLY bit (1) aligned static options (constant) init ("1"b); dcl FILE_ORIGINAL char (32) static options (constant) init ("file_original_yn"); dcl FORMAT_SEG_NAME char (32) static options (constant) init ("format_orig_seg"); dcl INCLUDE_ORIGINAL char (19) static options (constant) init ("include_original_yn"); dcl LOG char (1) static options (constant) init ("l"); dcl MAILFILE_SUFFIX char (6) static options (constant) init ("sv.mbx"); dcl NAME char (16) static options (constant) init ("xmail_reply_msg_"); dcl NL char (1) aligned static options (constant) init (" "); dcl NO_SELECTION bit (1) aligned static options (constant) init ("0"b); dcl NO_WIDTH_LIMIT fixed bin static options (constant) init (-1); dcl ORIGINAL_IN_WINDOW char (21) static options (constant) init ("original_up_window_yn"); dcl ORIG_SEG_NAME char (32) static options (constant) init ("orig_reply_seg"); dcl PROBLEM char (60) static options (constant) init ("Replying terminated. An internal program error has occurred."); dcl REPLY_SEG_NAME char (13) static options (constant) init ("reply_msg_seg"); dcl QUIT char (1) static options (constant) init ("q"); dcl SECONDS bit (2) static options (constant) init ("11"b); dcl SAVE_MAILBOX char (15) static options (constant) init ("save_mailfile"); dcl SAVE_MESSAGE char (15) static options (constant) init ("save_message_yn"); dcl STOP char (1) static options (constant) init ("q"); dcl USE_SCREEN_WIDTH fixed bin aligned static options (constant) init (-1); dcl VIEW_SEG_NAME char (32) static options (constant) init ("view_reply_seg"); dcl WHITE_SPACE_COMMA char (6) aligned static options (constant) init (" ,"); /* HT VT NL comma */ /* INTERNAL STATIC */ dcl ext_pname char (168) int static; dcl ext_ptr ptr init (null) int static; dcl ext_dir char (168) int static; dcl ext_file char (32) int static; /* AUTOMATIC */ dcl acknowledge char (3) varying; dcl bcc_list_ptr ptr; dcl bit_count fixed bin (24); dcl bit_count_view fixed bin (24); dcl buffer_size fixed bin (21); dcl buffer_used fixed bin (21); dcl cc_list_ptr ptr; dcl code fixed bin (35); dcl code1 fixed bin (35); dcl default_save_file char (32) var; dcl deferred_reply_exists bit (1); dcl deferred_seg_name char (32) var; dcl defrepl_seg_ptr ptr; dcl delete_def_reply bit (1); dcl delivery_results_need_cleanup bit (1) aligned; dcl emacs_seg_path_name char (168); dcl file_original char (3) var; dcl for_type char (32); dcl format_reply_length fixed bin; dcl format_reply char (33); dcl format_seg_ptr ptr; /* ptr to temp segment for indented formatted original message */ dcl idx fixed bin; dcl idx2 fixed bin; dcl iocb_ptr ptr; dcl include_original bit (1); /* flag: "1"=yes*/ dcl message_num fixed bin; dcl more_than_one bit (1); dcl no_chars fixed bin (21); dcl no_chars_format fixed bin (21); dcl no_chars_orig fixed bin (21); dcl no_chars_view fixed bin (21); dcl no_used fixed bin (21); dcl opt fixed bin; dcl original_in_window bit (1); /* flag: "1"=yes */ dcl orig_seg_ptr ptr; /* ptr to temp segment for printable original message */ dcl prompt_string char (160) var; dcl repl_message_ptr ptr; dcl reply_header char (27); dcl reply_msg_area_ptr ptr; dcl reply_msg_ptr ptr; dcl reply_seg_ptr ptr; dcl reply_to_list_ptr ptr; dcl resp char (1) var; dcl response char (3) varying; /* yes no or ask */ dcl save_message char (3) var; dcl saved_menu_size fixed bin; dcl sci_ptr ptr; dcl start_of_bcc fixed bin; dcl start_of_cc fixed bin; dcl start_of_orig fixed bin; /* original message */ dcl start_of_text fixed bin; dcl status fixed bin (35); dcl to_list_ptr ptr; dcl type fixed bin (2); dcl user_name char (22); dcl view_seg_ptr ptr; dcl yes_sw bit (1) aligned; dcl 1 auto_deliver_options like deliver_options; dcl 1 auto_format_message_options like format_message_options; dcl 1 auto_format_document_options like format_document_options; dcl 1 auto_message_body_section_parameter automatic like message_body_section_parameter; dcl 1 auto_parse_text_options like parse_text_options; dcl 1 auto_reply_options like reply_options; /* ENTRIES */ dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl emacs_ entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl format_document_$string entry (char (*), char (*), fixed bin (21), ptr, fixed bin (35)); dcl get_pdir_ entry () returns (char (168)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch_nnl entry () options (variable); dcl ioa_$nnl entry options (variable); dcl ioa_$rsnnl entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl mail_system_$add_body_section entry (ptr, ptr, fixed bin, fixed bin (35)); dcl mail_system_$deliver_message entry (ptr, ptr, ptr, fixed bin (35)); dcl mail_system_$free_address_list entry (ptr, fixed bin (35)); dcl mail_system_$free_message entry (ptr, fixed bin (35)); dcl mail_system_$read_message entry (ptr, fixed bin, fixed bin (35)); dcl mail_system_$replace_bcc entry (ptr, ptr, fixed bin (35)); dcl mail_system_$replace_cc entry (ptr, ptr, fixed bin (35)); dcl mail_system_$replace_reply_to entry (ptr, ptr, fixed bin (35)); dcl mail_system_$replace_to entry (ptr, ptr, fixed bin (35)); dcl mlsys_utils_$create_reply_message entry (ptr, ptr, ptr, fixed bin (35)); dcl mlsys_utils_$format_address_list_field entry (character (*) varying, ptr, fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl mlsys_utils_$format_message entry (ptr, ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl mlsys_utils_$format_text_field entry (character (*) varying, character (*), bit (1) aligned, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$free_delivery_results entry (ptr, fixed bin (35)); dcl mlsys_utils_$parse_address_list_text entry (character (*), ptr, character (8), ptr, ptr, fixed bin (35)); dcl mlsys_utils_$print_address_list_field entry (char (*) var, ptr, fixed bin, ptr, fixed bin (35)); dcl mlsys_utils_$print_delivery_results entry (ptr, bit (1) aligned, ptr, fixed bin (35)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl user_info_ entry (char(*)); dcl xmail_display_msgs_ entry (ptr, ptr, ptr); dcl xmail_error_$no_code entry options (variable); dcl xmail_error_$no_print entry options (variable); dcl xmail_error_$code_first entry options (variable); dcl xmail_file_msgs_$single_msg entry (ptr, char (32) var, bit (1) aligned); dcl xmail_file_msgs_$original_and_reply entry (ptr, ptr, char (32) var, bit (1) aligned); dcl xmail_get_str_ entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var); dcl xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); dcl xmail_redisplay_$all entry (); dcl xmail_redisplay_$menu entry (); dcl xmail_reply_msg_$ssu_exit entry (); dcl xmail_sw_$redisplay entry (); dcl xmail_sw_$update_position entry (char (*)); dcl xmail_sw_$update_usage entry (char (*)); dcl xmail_value_$get entry (char (*), char (*) var, fixed bin (35)); dcl xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35)); dcl xmail_window_manager_$quit_handler entry () returns (bit (1) aligned); dcl xmail_window_manager_$reconnect entry (); dcl xmail_window_manager_$set_menu_window_size entry (fixed bin, fixed bin (35)); dcl based_array (no_chars) char (1) based (reply_seg_ptr); dcl based_string char (no_chars) based (reply_seg_ptr); dcl based_string_format char (no_chars_format) based (format_seg_ptr); dcl based_string_orig char (no_chars_orig) based (orig_seg_ptr); dcl based_string_view char (no_chars_view) based (view_seg_ptr); dcl def_reply_string char (no_chars) based (defrepl_seg_ptr); /* AREA */ dcl reply_msg_area area aligned based (reply_msg_area_ptr); /* BUILTINS */ dcl (addr, after, before, char, codeptr, divide, decat, index, length, ltrim, null, rtrim, string, substr, sum) builtin; /* INCLUDE FILES */ %include access_mode_values; %page; %include iox_modes; %page; %include format_document_options; %page; %include mlsys_address_list; %page; %include mlsys_deliver_info; %page; %include mlsys_field_names; %page; %include mlsys_format_options; %page; %include mlsys_mailbox; %page; %include mlsys_message; %page; %include mlsys_parse_txt_options; %page; %include mlsys_reply_options; %page; %include star_structures; %page; %include terminate_file; %page; %include xmail_curr_msg_info; %page; %include xmail_data; %page; %include xmail_responses; %page; %include xmail_windows; %page; %include window_dcls; /* BEGIN */ START: /* Set ptrs to null and set up for cleanup & quit conditions */ saved_menu_size = xmail_windows.menu.height; call window_$clear_window (iox_$user_output, (0));/* ignore code */ more_than_one = "0"b; include_original, original_in_window = "0"b; reply_msg_area_ptr = get_system_free_area_ (); reply_seg_ptr, recipients_info_ptr, cc_list_ptr, bcc_list_ptr, to_list_ptr, repl_message_ptr, iocb_ptr, orig_seg_ptr, format_seg_ptr, view_seg_ptr = null (); defrepl_seg_ptr = null (); star_names_ptr = null (); star_entry_ptr = null (); sci_ptr = null (); delivery_results_need_cleanup = "0"b; /* See if there are any messages in the mailbox when reply option chosen */ mailbox_ptr = P_mailbox_ptr; curr_msgsp = P_curr_msgs_ptr; if mailbox_ptr = null () | curr_msgsp = null () then do; call ioa_ ("All messages have been discarded."); go to EXIT; end; on condition (quit) begin; on reissue_query begin; call window_$clear_window (iox_$user_output, (0)); goto RETRY (opt); end; if xmail_window_manager_$quit_handler () then do; call window_$clear_window (iox_$user_output, (0)); /* ignore code */ call xmail_window_manager_$set_menu_window_size (saved_menu_size, code); call xmail_sw_$update_position (""); call xmail_sw_$redisplay (); call xmail_redisplay_$all (); call ioa_ ("Replying terminated."); call CLEAN_UP; goto EXIT; end; end; on condition (cleanup) call CLEAN_UP; xmail_data.reply_request = "1"b; /* Create seg (for reply message) in process dir */ call hcs_$make_seg ("", REPLY_SEG_NAME, "", RW_ACCESS_BIN, reply_seg_ptr, code); if code ^= 0 then do; /* If seg already exists set its bit count to zero */ bit_count = 0; if code = error_table_$namedup | code = error_table_$segknown then call terminate_file_ (reply_seg_ptr, bit_count, TERM_FILE_BC, code); else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); end; /* Create seg (to place in the being-replied-to-message) */ call hcs_$make_seg ("", VIEW_SEG_NAME, "", RW_ACCESS_BIN, view_seg_ptr, code); if code ^= 0 then do; /* If seg already exists set its bit count to zero */ bit_count = 0; if code = error_table_$namedup | code = error_table_$segknown then call terminate_file_ (view_seg_ptr, bit_count, TERM_FILE_BC, code); else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); end; call iox_$attach_name (unique_chars_ ("0"b), iocb_ptr, "vfile_ " || rtrim (get_pdir_ ()) || ">" || rtrim (VIEW_SEG_NAME), codeptr (ENTRY_NAME), code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); call iox_$open (iocb_ptr, Stream_output, "0"b, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); /* Place the header & text of the message(s) being replied to in the "VIEW_SEG_NAME" seg */ call xmail_display_msgs_ (mailbox_ptr, curr_msgsp, iocb_ptr); if iocb_ptr ^= null () then do; call iox_$close (iocb_ptr, (0)); call iox_$detach_iocb (iocb_ptr, (0)); call iox_$destroy_iocb (iocb_ptr, (0)); end; /* Determine bit count of "VIEW_SEG_NAME" */ call hcs_$status_mins (view_seg_ptr, type, bit_count_view, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; /* Establish length of "based_string_view " */ no_chars_view = divide (bit_count_view, BITS_PER_CHAR, 17, 0); /* Determine if the original is to appear in the upper window */ call xmail_value_$get_with_default (ORIGINAL_IN_WINDOW, (YES), response, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT, "^/Unable to get a value for ""^a"" in the xmail value segment.", ORIGINAL_IN_WINDOW); if response = YES then original_in_window = "1"b; else original_in_window = "0"b; /* Establish pathname of "reply_seg_name" in process dir */ emacs_seg_path_name = rtrim (get_pdir_ ()) || ">" || REPLY_SEG_NAME; /* Determine absolute pathname of the the emacs extention (xmail_emacs_ext_main_) used by this procedure */ if ext_ptr = null () then do; call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "", ext_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT; end; /* Emacs extention will be called in the "reply" mode */ for_type = "reply"; /* Set up reply and deliver options */ recipients_info_n_lists = 3; /* make room for bcc */ allocate recipients_info in (reply_msg_area) set (recipients_info_ptr); recipients_info.area_ptr = get_system_free_area_ (); recipients_info.version = RECIPIENTS_INFO_VERSION_2; auto_reply_options.version = REPLY_OPTIONS_VERSION_2; auto_reply_options.to = null (); auto_reply_options.cc = null (); auto_reply_options.bcc = null (); auto_reply_options.flags.include_authors = "1"b; auto_reply_options.flags.include_self = "0"b; auto_reply_options.flags.mbz = "0"b; auto_deliver_options.version = DELIVER_OPTIONS_VERSION_2; auto_deliver_options.delivery_mode = ORDINARY_DELIVERY; auto_deliver_options.queueing_mode = ALWAYS_QUEUE_FOREIGN; auto_deliver_options.queued_notification_mode = NOTIFY_ON_ERROR; auto_deliver_options.flags.abort = "1"b; auto_deliver_options.flags.send_if_empty = "0"b; auto_deliver_options.flags.recipient_notification = "1"b; auto_deliver_options.flags.queue_mailing_lists = "0"b; auto_deliver_options.flags.mbz = "0"b; /* See if reply is for more than one message */ if curr_msgs.count > 1 then more_than_one = "1"b; /* Loop based on the number of messages being replied to */ default_save_file = "outgoing"; do idx = 1 to curr_msgs.count; message_num = curr_msgs.numbers (idx); /* Determine ptr to message structure */ if mailbox.messages (message_num).message_ptr = null then do; call mail_system_$read_message (mailbox_ptr, message_num, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, "l", "Unable to read message ^d. This is an internal programming error.", message_num); end; reply_msg_ptr = mailbox.messages (message_num).message_ptr; /* Recipients are to be included in reply. Note that the user can actually modify, to any extent he wishes, the recipient list while in the editor */ auto_reply_options.flags.include_recipients = "1"b; /* Create reply message structure */ repl_message_ptr = null (); call mlsys_utils_$create_reply_message (reply_msg_ptr, addr (auto_reply_options), repl_message_ptr, code); if repl_message_ptr ^= null () then do; message_ptr = repl_message_ptr; if message.to -> address_list.n_addresses = 0 then do; call ioa_ ("You are trying to reply to your own message. Reply to message no. ^d terminated.", message_num); go to pre_end; end; end; if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (5, SECONDS); go to pre_end; end; /* See if deferred reply exists for this message */ auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1; auto_parse_text_options.area_ptr = reply_msg_area_ptr; auto_parse_text_options.flags.list_errors = "0"b; auto_parse_text_options.flags.validate_addresses = "0"b; auto_parse_text_options.flags.include_invalid_addresses = "0"b; auto_parse_text_options.flags.mbz = "0"b; call user_info_ (user_name); /* we might need this */ /* to plug a name into the reply-to */ deferred_reply_exists = "0"b; delete_def_reply = "0"b; deferred_seg_name = unique_chars_ ((reply_msg_ptr -> message.header.message_id)) || ".reply"; call hcs_$star_ ((xmail_data.mail_dir), (deferred_seg_name), star_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, (0)); if star_entry_count = 1 then do; call hcs_$make_seg ((xmail_data.mail_dir), (deferred_seg_name), "", RW_ACCESS_BIN, defrepl_seg_ptr, (0)); call hcs_$status_mins (defrepl_seg_ptr, type, bit_count, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; if bit_count ^= 0 then do; RETRY (2): opt = 2; call ioa_$rsnnl ("A deferred reply for message ^d exists. Do you wish to use it? ", prompt_string, (0), message_num); call xmail_get_str_$yes_no (prompt_string, yes_sw); if yes_sw then do; no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0); reply_to_list_ptr = null; based_string = def_reply_string; if index(before(based_string, "Reply: || NL"), "Reply-To:") > 0 then do; call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "To:"), "Reply-To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, reply_to_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; end; else do; format_reply = ""; format_reply_length, buffer_size = length ("Reply-To: ") + length(user_name); buffer_used = 0; call mlsys_utils_$format_text_field (REPLY_TO_FIELDNAME, rtrim(user_name), ("0"b), format_reply_length, addr(format_reply), buffer_size, buffer_used, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; no_chars = format_reply_length + length (NL) + no_chars; bit_count = BITS_PER_CHAR * no_chars; based_string = format_reply || NL || based_string; end; call terminate_file_ (reply_seg_ptr, bit_count, TERM_FILE_BC, code); delete_def_reply = "1"b; deferred_reply_exists = "1"b; end; else do; RETRY (3): opt = 3; call xmail_get_str_$yes_no ("Do you wish to discard it? ", yes_sw); if yes_sw then delete_def_reply = "1"b; end; end; end; if ^deferred_reply_exists then do; /* create a reply */ call query_for_include_original (); /* Set length of based_string temporarily to 5000 chars */ no_chars = 5000; no_used = 0; /* Get name(s) of sender of message being replied to */ call mlsys_utils_$format_address_list_field (REPLY_TO_FIELDNAME, message.header.reply_to, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; if no_used > length ("Reply-To: ") then; else do; based_string = substr (based_string, 1, no_used) || rtrim(user_name); no_used = no_used + length (user_name); end; based_string = substr (based_string, 1, no_used) || NL; no_used = no_used + length (NL); call mlsys_utils_$format_address_list_field (TO_FIELDNAME, message.header.to, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; based_string = substr (based_string, 1, no_used) || NL; no_used = no_used + length (NL); /* If there were secondary recipients in the original message then determine the recipient list and append it to based_string so that the user may modify it via the editor */ start_of_cc = no_used + 1; call mlsys_utils_$format_address_list_field (CC_FIELDNAME, message.header.cc, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; based_string = substr (based_string, 1, no_used) || NL; no_used = no_used + length (NL); /* If there were bcc recipients in the original message then determine the recipient list and append it to based_string so that the user may modify it via the editor */ start_of_bcc = no_used + 1; call mlsys_utils_$format_address_list_field (BCC_FIELDNAME, message.header.bcc, NO_WIDTH_LIMIT, reply_seg_ptr, no_chars, no_used, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; based_string = substr (based_string, 1, no_used) || NL; no_used = no_used + length (NL); based_string = substr (based_string, 1, no_used) || "Reply: " || NL; no_used = no_used + length ("Reply: ") + length (NL); /* If the original is to be included, include it here */ if include_original then call insert_original_message; bit_count = no_used * BITS_PER_CHAR; call terminate_file_ (reply_seg_ptr, bit_count, TERM_FILE_BC, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); end; /* Remove "For help press Funtion Key 1 " from status window. */ reply_header = "Replying to message no." || ltrim (char (message_num)); call xmail_sw_$update_usage (reply_header); call xmail_sw_$update_position ("------------------------------------------------------------------------------"); call xmail_sw_$redisplay (); /* See if more then one message is being replied-to */ if more_than_one then based_string_view = decat (based_string_view, " #" || rtrim (ltrim (char (message_num))) || " (", "011"b); based_string_view = decat (based_string_view, "Date:", "011"b); bit_count_view = length (decat (based_string_view, "-----(" || ltrim (rtrim (char (message_num))) || ")-----", "110"b)) * BITS_PER_CHAR; call terminate_file_ (view_seg_ptr, bit_count_view, TERM_FILE_BC, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); if original_in_window then call xmail_window_manager_$set_menu_window_size (2, code); else call xmail_window_manager_$set_menu_window_size (1, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); call window_$clear_window (xmail_windows.menu.iocb, (0)); /* ignore code */ if original_in_window then call ioa_$ioa_switch_nnl (xmail_windows.menu.iocb, " *** Use ESC l to view previous page, ESC h to view next page ***"); call window_$clear_window (iox_$user_output, (0)); /* ignore code */ call ioa_ ("...Please wait for editor..."); /* Suppress the original if necessary. */ if ^original_in_window then do; call terminate_file_ (view_seg_ptr, 0, TERM_FILE_BC, code); end; /* Call the editor now */ call emacs_ (iox_$user_output, (emacs_seg_path_name), ext_pname, addr (for_type), status); call xmail_window_manager_$set_menu_window_size (saved_menu_size, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); if status = 1 then do; deferred_seg_name = unique_chars_ ((reply_msg_ptr -> message.header.message_id)) || ".reply"; call hcs_$make_seg ((xmail_data.mail_dir), (deferred_seg_name), "", RW_ACCESS_BIN, defrepl_seg_ptr, code); if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segknown then do; call ioa_ ("Sorry, unable to save ""deferred reply"" for message ^d. ^/This is an internal error.", message_num); if curr_msgs.count > 1 then call timer_manager_$sleep (4, SECONDS); go to pre_end; end; call hcs_$status_mins (reply_seg_ptr, type, bit_count, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; call terminate_file_ (defrepl_seg_ptr, bit_count, TERM_FILE_BC, code); /* Get number of chars in seg */ no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0); def_reply_string = based_string; call ioa_ ("Deferred reply for message ^d saved.", message_num); if more_than_one then call timer_manager_$sleep (3, SECONDS); delete_def_reply = "0"b; go to pre_end; end; if status ^= 0 then do; call xmail_window_manager_$reconnect (); call ioa_ ("Reply to message ^d terminated.", message_num); if curr_msgs.count > idx then do; call ioa_$nnl ("^/Do you still wish to reply to message(s): "); do idx2 = idx + 1 to curr_msgs.count; call ioa_$nnl (" ^d", curr_msgs.numbers (idx2)); end; /* end do loop */ call xmail_get_str_$yes_no (" ? ", yes_sw); if yes_sw then go to pre_end; else call ioa_ ("Replying terminated."); end; call CLEAN_UP; goto EXIT; end; call hcs_$status_mins (reply_seg_ptr, type, bit_count, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; if bit_count <= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); no_chars = divide (bit_count, BITS_PER_CHAR, 17, 0); /* Delete deferred reply if one existed */ if delete_def_reply then do; call delete_$ptr (defrepl_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, (0)); /* ignore code */ delete_def_reply = "0"b; end; to_list_ptr, cc_list_ptr, bcc_list_ptr = null (); /* Add bcc handling */ call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "Reply:"), "bcc:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, bcc_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; if bcc_list_ptr ^= null () then do; call mail_system_$replace_bcc (message_ptr, bcc_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; end; /* Add Reply-To handling */ call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, NL || "To:"), "Reply-To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, reply_to_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; if reply_to_list_ptr ^= null () then do; call mail_system_$replace_reply_to (message_ptr, reply_to_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; end; /* reply-to handling */ /* cc handling */ call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "bcc:"), "cc:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, cc_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; if cc_list_ptr ^= null () then do; call mail_system_$replace_cc (message_ptr, cc_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; end; call mlsys_utils_$parse_address_list_text (rtrim (after (before (based_string, "cc:"), NL || "To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, to_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; call mail_system_$replace_to (message_ptr, to_list_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; message_body_section_ptr = addr (auto_message_body_section_parameter.section); auto_message_body_section_parameter.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; message_preformatted_body_section.header.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_preformatted_body_section.header.section_n_lines = -1; start_of_text = index (based_string, "Reply:") + length ("Reply:") + length (NL); message_preformatted_body_section.text_ptr = addr (based_array (start_of_text)); message_preformatted_body_section.text_lth = length (substr (rtrim (based_string), start_of_text)); recipients_info.lists (*).recipients_result_list_ptr = null (); recipients_info.lists (1).address_list_ptr = message.to; recipients_info.lists (2).address_list_ptr = message.cc; recipients_info.lists (3).address_list_ptr = message.bcc; call mail_system_$add_body_section (repl_message_ptr, addr (auto_message_body_section_parameter), 1, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; call xmail_value_$get_with_default (ACKNOWLEDGE, (NO), acknowledge, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT, "/^Unable to get a value for ""^a"" in the xmail value segment.", ACKNOWLEDGE); if acknowledge = NO then auto_deliver_options.flags.acknowledge = "0"b; else if acknowledge = ASK then do; RETRY (4): opt = 4; call xmail_get_str_$yes_no ("Do you want your reply acknowledged? ", yes_sw); if yes_sw then auto_deliver_options.flags.acknowledge = "1"b; else auto_deliver_options.flags.acknowledge = "0"b; end; else if acknowledge = YES then auto_deliver_options.flags.acknowledge = "1"b; else call xmail_error_$code_first (error_table_$bad_segment, NAME, QUIT, "^/An invalid value for ""^a"" was found in the xmail value segment.", ACKNOWLEDGE); call mail_system_$deliver_message (repl_message_ptr, recipients_info_ptr, addr (auto_deliver_options), code); delivery_results_need_cleanup = "1"b; if code ^= 0 then do; if code = mlsys_et_$no_a_permission then call xmail_error_$no_code (code, NAME, CONTINUE, "You do not have permission to send message to at least one of the recipients."); if n_failed_recipients > 0 then do; call ioa_ ("Reply to message no.^d could not be sent.^/", message_num); call ssu_$standalone_invocation (sci_ptr, "", "", null (), xmail_reply_msg_$ssu_exit, code1); if code1 = 0 then call mlsys_utils_$print_delivery_results (sci_ptr, ERRORS_ONLY, recipients_info_ptr, code1); else call xmail_error_$no_code (code1, NAME, LOG, "The reason cannot be printed due to an internal programming error"); call ssu_$destroy_invocation (sci_ptr); if idx = curr_msgs.count then go to pre_end; resp = ""; do while (resp = ""); call xmail_get_str_ ("^/Press RETURN to continue; BREAK to stop.", "", "", "", resp); end; go to pre_end; end; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); call timer_manager_$sleep (4, SECONDS); goto pre_end; end; /* Issue the statement that the reply was sent. */ call ioa_ ("Reply to message no. ^d sent: ", message_num); call mlsys_utils_$print_address_list_field ("To", to_list_ptr, USE_SCREEN_WIDTH, null, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""To:"" recipient(s)."); if cc_list_ptr ^= null then do; call mlsys_utils_$print_address_list_field ("cc", cc_list_ptr, USE_SCREEN_WIDTH, null, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""cc:"" recipient(s)."); end; else call ioa_ ("cc: "); /* Add for bcc */ if bcc_list_ptr ^= null then do; call mlsys_utils_$print_address_list_field ("bcc", bcc_list_ptr, USE_SCREEN_WIDTH, null, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""bcc:"" recipient(s)."); end; else call ioa_ ("bcc: "); /* Save the reply message for the user */ call xmail_value_$get (SAVE_MAILBOX, default_save_file, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT, "^/Unable to get a value for ""^a"" in the xmail value segment.", SAVE_MAILBOX); call xmail_value_$get (SAVE_MESSAGE, save_message, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, QUIT, "^/Unable to get a value for ""^a"" in the xmail value segment.", SAVE_MESSAGE); call xmail_value_$get (FILE_ORIGINAL, file_original, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, "q", "^/Unable to get value for ""^a"" in the xmail value segment.", FILE_ORIGINAL); if save_message = YES then do; if file_original = YES then do; if default_save_file = ASK then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if file_original = ASK then do; RETRY (5): opt = 5; call xmail_get_str_$yes_no ("Do you wish to file the original before the reply?", yes_sw); if yes_sw then do; if default_save_file = ASK then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if default_save_file = ASK then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if file_original = NO then do; if default_save_file = ASK then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else call xmail_error_$code_first (error_table_$bad_segment, NAME, "q", "^/An invalid value for ""^a"" was found in the xmail value segment.", FILE_ORIGINAL); end; else if save_message = ASK then do; RETRY (6): opt = 6; call xmail_get_str_$yes_no ("Do you wish to save this reply? ", yes_sw); if yes_sw then do; if file_original = YES then do; if default_save_file = ASK then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if file_original = ASK then do; RETRY (7): opt = 7; call xmail_get_str_$yes_no ("Do you wish to file the original before the reply?", yes_sw); if yes_sw then do; if default_save_file = ASK then call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$original_and_reply (reply_msg_ptr, repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if default_save_file = ASK then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if file_original = NO then do; if default_save_file = ASK then call xmail_file_msgs_$single_msg (repl_message_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$single_msg (repl_message_ptr, minus_suffix ((default_save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else call xmail_error_$code_first (error_table_$bad_segment, NAME, "q", "^/An invalid value for ""^a"" was found in the xmail value segment.", FILE_ORIGINAL); end; end; else if save_message ^= NO then call xmail_error_$code_first (error_table_$bad_segment, NAME, "q", "^/An invalid value for ""^a"" was found in the xmail value segment.", SAVE_MESSAGE); if idx ^= curr_msgs.count then call timer_manager_$sleep (4, SECONDS); pre_end: call MESSAGE_CLEAN_UP (); end; /* end of do loop */ call CLEAN_UP (); EXIT: return; /* ENTRY POINTS */ ssu_exit: entry; /* This entry doesn't do anything but it is called by ssu_$print_message */ /* which is called by mlsys_utils_$print_delivery_results. */ return; /* INTERNAL PROCEDURES */ MESSAGE_CLEAN_UP: proc (); if repl_message_ptr ^= null () then do; call mail_system_$free_message (repl_message_ptr, code); repl_message_ptr = null (); end; if to_list_ptr ^= null () then do; call mail_system_$free_address_list (to_list_ptr, code); to_list_ptr = null (); end; if cc_list_ptr ^= null () then do; call mail_system_$free_address_list (cc_list_ptr, code); cc_list_ptr = null (); end; /* Add for bcc */ if bcc_list_ptr ^= null () then do; call mail_system_$free_address_list (bcc_list_ptr, code); bcc_list_ptr = null (); end; if recipients_info_ptr ^= null () then do; if delivery_results_need_cleanup then do; call mlsys_utils_$free_delivery_results (recipients_info_ptr, code); if code ^= 0 then call xmail_error_$no_print (code, NAME, CONTINUE, "While cleaning up delivery results."); end; end; return; end MESSAGE_CLEAN_UP; minus_suffix: proc (name, suffix) returns (char (*) var); /* PARAMETERS */ dcl name char (*); dcl suffix char (*); /* AUTOMATIC */ dcl reverse_name char (length (name)) var; dcl reverse_suffix char (length (suffix)) var; /* BUILTINS */ dcl (after, index, length, reverse, rtrim) builtin; reverse_name = reverse (rtrim (name)); reverse_suffix = reverse (rtrim (suffix)); if index (reverse_name, reverse_suffix || ".") ^= 1 then return (name); else return (reverse (after (reverse_name, reverse_suffix || "."))); end minus_suffix; query_for_include_original: proc; /* Determine if the original is to be included in the reply */ call xmail_value_$get_with_default (INCLUDE_ORIGINAL, (NO), response, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, "q", "^/Unable to get a value for ""^a"" in the xmail value segment.", INCLUDE_ORIGINAL); if response = YES then include_original = "1"b; else if response = ASK then do; RETRY (1): opt = 1; call xmail_get_str_$yes_no ("Do you wish to include the original in this reply? ", yes_sw); if yes_sw then include_original = "1"b; end; else include_original = "0"b; if include_original then do; /* Create segs for the printable original message before and after indenting and setup format_document_ options */ call hcs_$make_seg ("", ORIG_SEG_NAME, "", RW_ACCESS_BIN, orig_seg_ptr, code); if code ^= 0 then do; /* If seg already exists set its bit count to zero */ bit_count = 0; if code = error_table_$namedup | code = error_table_$segknown then call terminate_file_ (orig_seg_ptr, bit_count, TERM_FILE_BC, code); else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); end; call hcs_$make_seg ("", FORMAT_SEG_NAME, "", RW_ACCESS_BIN, format_seg_ptr, code); if code ^= 0 then do; /* If seg already exists set its bit count to zero */ bit_count = 0; if code = error_table_$namedup | code = error_table_$segknown then call terminate_file_ (format_seg_ptr, bit_count, TERM_FILE_BC, code); else call xmail_error_$no_code (code, NAME, STOP, "^a", PROBLEM); end; /* Set up format_message options */ auto_format_message_options.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; auto_format_message_options.line_length = NO_WIDTH_LIMIT; auto_format_message_options.envelope_formatting_mode = DEFAULT_FORMATTING_MODE; auto_format_message_options.header_formatting_mode = DEFAULT_FORMATTING_MODE; auto_format_message_options.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE; auto_format_message_options.include_body = "1"b; /* Set up format_document options */ auto_format_document_options.version_number = format_document_version_2; auto_format_document_options.indentation = 4; auto_format_document_options.line_length = DEFAULT_WIDTH; string (auto_format_document_options.switches) = ""b; auto_format_document_options.galley_sw = "1"b; /* ... don't insert page breaks */ auto_format_document_options.literal_sw = "1"b; /* ... don't recognize controls in the text */ auto_format_document_options.dont_break_indented_lines_sw = "1"b; /* ... don't break lines which are indented */ auto_format_document_options.dont_fill_sw = "1"b; /* ... don't fill */ auto_format_document_options.syllable_size = 0; end; end query_for_include_original; insert_original_message: proc; /* Internal procedure to format the original message into printable form, indent it, and then add it to the based_string in the reply segment for editing */ start_of_orig = no_used + 1; no_chars_orig = 0; GROW_MORE: call mlsys_utils_$format_message (reply_msg_ptr, addr (auto_format_message_options), orig_seg_ptr, no_chars, no_chars_orig, code); if code = error_table_$smallarg then do; no_chars = no_chars + 5000; goto GROW_MORE; end; else if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); go to pre_end; end; no_chars_format = no_chars; call format_document_$string (based_string_orig, based_string_format, no_chars_format, addr (auto_format_document_options), code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); go to pre_end; end; /* Append indented original and add the number of characters */ based_string = substr (based_string, 1, no_used) || based_string_format; no_used = no_used + no_chars_format; /* Append a newline */ based_string = substr (based_string, 1, no_used) || NL; no_used = no_used + length (NL); return; end insert_original_message; CLEAN_UP: proc (); if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); xmail_data.reply_request = "0"b; call xmail_redisplay_$menu (); if delete_def_reply then call delete_$ptr (defrepl_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, (0)); if reply_seg_ptr ^= null () then do; call delete_$ptr (reply_seg_ptr, DELETE_SEG_FORCE_CHASE, NAME, code); reply_seg_ptr = null (); end; call MESSAGE_CLEAN_UP (); if iocb_ptr ^= null then do; call iox_$close (iocb_ptr, (0)); /* ignore code */ call iox_$detach_iocb (iocb_ptr, (0)); /* ignore code */ call iox_$destroy_iocb (iocb_ptr, (0)); /* ignore code */ end; if view_seg_ptr ^= null () then do; call delete_$ptr (view_seg_ptr, DELETE_SEG_FORCE, NAME, (0)); /* ignore code */ view_seg_ptr = null (); end; if orig_seg_ptr ^= null () then do; call delete_$ptr (orig_seg_ptr, DELETE_SEG_FORCE, NAME, (0)); /* ignore code */ orig_seg_ptr = null (); end; if format_seg_ptr ^= null () then do; call delete_$ptr (format_seg_ptr, DELETE_SEG_FORCE, NAME, (0)); /* ignore code */ format_seg_ptr = null (); end; if star_names_ptr ^= null () then free star_names;/* order is important */ if star_entry_ptr ^= null () then free star_entries; if recipients_info_ptr ^= null () then do; free recipients_info in (reply_msg_area); recipients_info_ptr = null (); end; return; end CLEAN_UP; end xmail_reply_msg_;  xmail_review_defers_.pl1 09/02/88 0759.6r w 09/02/88 0746.8 49743 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Begin xmail_review_defers_ */ /* Written by R. Ignagni 1/7/82 83-07-07 DJ Schimke: Removed unreferenced dcl of date and declared addr, divide, null, rtrim, and sum builtin functions. 83-10-06 DJ Schimke: Replaced all calls to xmail_get_str_ with calls to xmail_get_str_$yes_no. 84-06-21 JAFalksen: replaced date_time_$fstime/convert_date_to_binary_ with cv_fstime_ */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* The purpose of this proc is to see if there are deferred replies in the xmail */ /* directory that are over a certain time limit. If so, the user is querired to see if */ /* he/she wishes to review them. If so these will be displayed and the user will be */ /* asked if he/she wishes to delete them */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ xmail_review_defers_: proc (file_type, file_suffix, delta); /* Parameter */ dcl file_type char (*) parameter; dcl file_suffix char (*) parameter; dcl delta fixed bin; /* External Static */ dcl iox_$user_output ptr ext static; /* Constant */ dcl DELETE_SEG_FORCE bit (6) int static options (constant) init ("100100"b); dcl NAME char (20) static options (constant) init ("xmail_review_defers_"); dcl N_MICROSECONDS_PER_DAY fixed bin (71) int static options (constant) init (86400000000); /* (60000000 * 60 * 24) */ /* Condition */ dcl cleanup condition; /* Automatic */ dcl clock_now fixed bin (71); dcl clock_then fixed bin (71); dcl code fixed bin (35); dcl difference fixed bin; dcl idx fixed bin; dcl prompt_string char (100) var; dcl yes_sw bit (1) aligned; dcl 1 auto_status_branch like status_branch; /* Entries */ dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl cv_fstime_ entry (bit (36) aligned) returns (fixed bin (71)); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); /* Builtin */ dcl (addr, divide, null, rtrim, sum) builtin; /* Include */ %page; %include access_mode_values; %page; %include status_structures; %page; %include star_structures; %page; %include xmail_data; %page; %include xmail_responses; star_entry_ptr, star_names_ptr = null; on condition (cleanup) call CLEANUP; call hcs_$star_ ((xmail_data.mail_dir), "*." || file_suffix, star_BRANCHES_ONLY, get_system_free_area_ (), star_entry_count, star_entry_ptr, star_names_ptr, (0)); if star_entry_count > 0 then do; call convert_date_to_binary_ ("", clock_now, code); /* get current time */ do idx = 1 to star_entry_count; call hcs_$status_ ((xmail_data.mail_dir), (rtrim (star_names (idx))), 0, addr (auto_status_branch), null (), code); clock_then = cv_fstime_ ((auto_status_branch.short.dtu)); difference = divide ((clock_now - clock_then), N_MICROSECONDS_PER_DAY, 17, 0); if difference > delta then do; call iox_$control (iox_$user_output, "reset_more", null (), (0)); call ioa_$rsnnl ("You have a deferred ^a at least ^d days old. Do you wish to review it? ", prompt_string, (0), file_type, difference); call xmail_get_str_$yes_no (prompt_string, yes_sw); if yes_sw then call review_this_seg; end; end; /* end of do loop */ end; call CLEANUP; return; review_this_seg: proc; dcl seg_string char (siz) based (seg_ptr); dcl siz fixed bin; dcl seg_ptr ptr; dcl no_of_bits fixed bin (24); call hcs_$make_seg ((xmail_data.mail_dir), (rtrim (star_names (idx))), "", RW_ACCESS_BIN, seg_ptr, (0)); call hcs_$status_mins (seg_ptr, 1, no_of_bits, (0)); siz = divide (no_of_bits, 9, 17, 0); call ioa_ ("^/^a ^/", seg_string); call iox_$control (iox_$user_output, "reset_more", null (), (0)); call ioa_$rsnnl ("Do you wish to discard the deferred ^a? ", prompt_string, (0), file_type, code); call xmail_get_str_$yes_no (prompt_string, yes_sw); if yes_sw then call delete_$ptr (seg_ptr, DELETE_SEG_FORCE, NAME, (0)); end review_this_seg; CLEANUP: proc; if star_names_ptr ^= null () then free star_names; if star_entry_ptr ^= null () then free star_entries; end CLEANUP; end xmail_review_defers_;  xmail_select_file_.pl1 09/02/88 0759.6rew 09/02/88 0736.1 279063 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-07,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Add a new entrypoint for when the user is allowed to read mail from other users' mailboxes ($foreign_mailboxes). 2) change(86-01-28,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Establish an on unit for reissue_query so that the choice menu can be redrawn or the question which the user typed quit after can be repeated. TRs 18711 18974. 3) change(86-06-02,Blair), approve(86-06-02,MCR7358), audit(86-06-04,RBarstad), install(86-06-04,MR12.0-1069): Rearrange code in get_menu_choice to keep track of which menu we selected create from, the one where create means a file name or the one where create means a user mbx. PBF. 4) change(88-06-16,Blair), approve(88-07-27,MCR7931), audit(88-08-25,RBarstad), install(88-09-02,MR12.2-1098): Change the call that gets the file type from hcs_$status_minf to fs_util_$get_type so that we don't need 's' access on the containing directory. This will allow us to access a mailbox through a link when that mailbox is in a dir to which we have no access. Error list #141. END HISTORY COMMENTS */ /* xmail_select_file_ This program is called to select a file for processing. Input parameters give a text description of the type of file desired, the suffix, whether old and/or new files are acceptable. A directory name, entry name prefix, and status code are returned. The file is intended to come from the xmail directory, and is so restricted in this version. (General pathnames might someday be allowed.) When new files are not allowed and only a single candidate exists in the xmail directory, it is returned without comment. In all other cases the user is asked to make the selection. This is first done with a simple prompt and text reply. By responding to the prompt with "??" the user can switch to menu selection from the available choices. Error Returns: 0 Dir & Prefix have been set for the file selected by the user. If New_ok was true the file may not exist. other The selection was unsuccessful for some reason. A diagnostic will already have been issued about the problem, but not what is to be done about it. Generally the caller should abort the current menu selection and let the user choose what to do next. There are three entrypoints: xmail_select_file_ allows the user to select a file as described above. xmail_select_file_$exclude allows the user to select a file as described above, excluding certain names from the users list of possible selections. xmail_select_file_$caller_msg works like xmail_select_file_ except that the caller has control over the content of the filename prompt. */ /* Written February 1982 by Suzanne Krupp */ /* Modified: 82-12-15 Dave Schimke: Changed the format of the list internal proc output to a multiple-column output more consistant with xmail_Mail_File_Maint_. Also added a test for code = 0 before reporting a link inconsistency. This prevents messages of the type "A link points to nowhere" when in fact no link exists. 83-05-31 Dave Schimke: Changed all references to the nonexistent error code error_table_$badarg to error_table_$bad_arg. TR15273 83-09-14 Dave Schimke: Removed the restriction that files be single component names since the code which creates files doesn't enforce this anyway. This, however, required the addition of code to prevent "**.sv.mbx" from being selected as "**.mbx". TR11956 TR13411 83-10-11 Dave Schimke: Replaced call to xmail_get_line with call to xmail_get_str_. Added cleanup handler to free allocated structures. Added Create and Exists flags to the calling sequences. Create means the user selected create on the dynamic menu. Exists tells the state of the selected file ("1"b = file exists). 84-09-06 JG Backs: Modified to allow lists as menus personalization option to be checked before prompt. 84-10-26 JG Backs: Modified get_menu_choice internal procedure to indicate the caller needs to create a file if there are no menu items and lists as menus personalization option is set to yes. 84-10-31 JG Backs: Modified to check response from call to xmail_get_str in MAIN procedure to make sure file name is not too long. 85-01-06 JG Backs: Modified get_menu_choice and validate_file procedures to add calls to timer_manager_$sleep after printing some error messages if the lists as menus personalization option is set to yes. This allows the message to remain on the screen long enough to read before the menu is redisplayed. In get_menu_choice, two errors (unable to get a list of files or create a dynamic menu), were changed to interrupt processing if the lists as menus personalization option is set to yes. Also added code in validate_file to test for incorrect access. Bugfix. 85-01-18 JG Backs: Modified all the calls to timer_manager_$sleep to delay 5 seconds instead of 3 so the user has more time to read the message on the screen. Audit change. */ xmail_select_file_: proc (File_type, Suffix, Default, Old_ok, New_ok, Dir, Prefix, Create, Exists, code); Own_msg = "0"b; Excluding_some_names = "0"b; call MAIN; return; exclude: entry (File_type, Suffix, Default, Old_ok, New_ok, Exclude_array, Dir, Prefix, Create, Exists, code); Own_msg = "0"b; Excluding_some_names = "1"b; call MAIN; return; caller_msg: entry (File_type, Suffix, Default, Old_ok, New_ok, Dir, Prefix, Caller_message, Create, Exists, code); Own_msg = "1"b; Excluding_some_names = "0"b; call MAIN; return; foreign_mailboxes: entry (File_type, Suffix, Default, Old_ok, New_ok, Dir, Prefix, Caller_message, User, Exists, code); dcl user_id char (60); dcl foreign_user_addr_ptr ptr; dcl full_pathname char (168); dcl mt_address_ptr ptr; dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35)); dcl mlsys_et_$invalid_address_syntax fixed bin(35) ext static; code = 0; Dir = ""; Prefix, entryname = ""; Names_ptr, Dyn_menup, star_names_ptr, star_entry_ptr = null; N_names = 0; Selected_dir = xmail_data.mail_dir; Default_file = Default; User, Exists = "0"b; new_ok = New_ok; old_ok = Old_ok; Area_ptr = get_system_free_area_ (); on condition (cleanup) call CLEANUP; starname = "**." || Suffix; Cant_get_list = "0"b; call get_candidates (Selected_dir, starname, Names_ptr, N_names, code); if code = error_table_$nomatch then ; else if code ^= 0 then do; Cant_get_list = "1"b; code = 0; end; Prompt = get_caller_msg (); selecting = "1"b; do while (selecting); RETRY (2): opt = 2; Selected_file = ""; if xmail_data.lists_as_menus & old_ok then call get_menu_choice (Selected_file); /* Always list as menu */ else do; call xmail_get_str_ (Prompt, "", PROMPT_REPLIES_HELP, explain_question (), response); if response = "??" then call get_menu_choice (Selected_file); /* else if search (response, INVALID_CHARS) ^= 0 then do; call ioa_ ("The character ""^a"" is invalid in a ^a name.", substr (response, search (response, INVALID_CHARS), 1), File_type); Selected_file = ""; end; else if length (response) > (VALID_LENGTH - length (Suffix) - 1) then do; call ioa_ ("The ""^a"" name is too long.", File_type); Selected_file = ""; end; */ else Selected_file = response; end; if Selected_file ^= "" then do; if Selected_file = USER_MAILBOX then do; call xmail_get_str_ ("Enter user name of mailbox to be processed: ", "", PROMPT_REPLIES_HELP, "user_mailbox", response); TRY_AGAIN: user_id = rtrim (response); call mlsys_utils_$parse_address_text (rtrim (user_id), foreign_user_addr_ptr, code); if code = mlsys_et_$invalid_address_syntax then do; if index (rtrim(response), "{") = 0 then do; call absolute_pathname_ (rtrim(response), full_pathname, code); if code = 0 then begin; dcl temp_address char (length (rtrim (full_pathname)) + 6); temp_address = "{mbx " || rtrim(full_pathname) || "}"; call mlsys_utils_$parse_address_text (temp_address, foreign_user_addr_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, "i", "Can't locate a mailbox with this pathname, ^a.", response); goto EXIT_FOREIGN_MAILBOX; end; end; else do; call xmail_error_$no_code (code, NAME, "i", "Can't locate a mailbox with this pathname, ^a.", response); goto EXIT_FOREIGN_MAILBOX; end; end; else do; call ioa_ ("The character ""{"" is invalid in a mailbox name."); goto EXIT_FOREIGN_MAILBOX; end; end; else if code ^= 0 then do; /* not a savebox or user */ call xmail_error_$no_code (code, NAME, "i", " Can't get a mail table address for this user ^a.", response); goto EXIT_FOREIGN_MAILBOX; end; call GET_PATHNAME (foreign_user_addr_ptr, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, "i", "Can't get mail table address for this user_id, ^a.", response); goto EXIT_FOREIGN_MAILBOX; end; else do; Prefix = rtrim (entryname); selecting = "0"b; User = "1"b; end; end; else do; call validate_file (Selected_file, Exists, code); if code = 0 then do; Prefix = rtrim (Selected_file); Dir = Selected_dir; selecting = "0"b; end; else do; Selected_file = USER_MAILBOX; goto TRY_AGAIN; end; end; end; end; EXIT_FOREIGN_MAILBOX: call CLEANUP; return; GET_PATHNAME: procedure (P_address_ptr, code); dcl P_address_ptr pointer parameter; dcl code fixed binary (35) parameter; dcl mlsys_et_$no_address_pathname fixed bin(35) ext static; dcl address_type fixed bin; call mail_system_$get_address_type (P_address_ptr, address_type, code); if code ^= 0 then return; if (address_type = INVALID_ADDRESS | address_type = NAMED_GROUP_ADDRESS | address_type = MAILING_LIST_ADDRESS | address_type = FOREIGN_ADDRESS | address_type = FORUM_ADDRESS) then do; code = mlsys_et_$no_address_pathname; end; else if address_type = USER_MAILBOX_ADDRESS | address_type = LOGBOX_ADDRESS | address_type = SAVEBOX_ADDRESS | address_type = MAILBOX_ADDRESS then do; call mail_system_$get_address_pathname (P_address_ptr, Dir, entryname, ((32)" "), code); end; else do; /* *** mail table address */ call mail_system_$get_mail_table_address (P_address_ptr, mt_address_ptr, code); if code = 0 then call GET_PATHNAME (mt_address_ptr, code); end; end GET_PATHNAME; /*** Global variables ***/ /* Parameter */ dcl Caller_message char (*); dcl Cant_get_list bit (1) aligned; dcl Create bit (1) aligned; dcl Default char (*); dcl Dir char (168); dcl Exists bit (1) aligned; dcl Exclude_array (*) char (32) aligned; dcl File_type char (*); dcl New_ok bit (1) aligned; dcl Old_ok bit (1) aligned; dcl Prefix char (32) var; dcl User bit (1) aligned; dcl Suffix char (*); /* Automatic */ dcl Area_ptr ptr; dcl Default_file char (32); dcl Dyn_menup ptr; dcl entryname char (32); dcl Excluding_some_names bit (1) aligned; dcl N_names fixed bin; dcl Names_ptr ptr; dcl new_ok bit (1) aligned; dcl old_ok bit (1) aligned; dcl opt fixed bin; dcl Own_msg bit (1) aligned; dcl Prompt char (256) var; dcl Selected_dir char (168); dcl Selected_file char (32); /* Based */ dcl Based_area area based (Area_ptr); dcl Names (N_names) char (32) aligned based (Names_ptr); /* Condition */ dcl cleanup condition; dcl reissue_query condition; /*** Non-global ***/ /* Automatic */ dcl code fixed bin (35); dcl response char (256) var; dcl selecting bit (1) aligned; dcl starname char (32); /* Builtin */ dcl (index, length, null, rtrim, search, substr, sum) builtin; /* Entries */ dcl get_system_free_area_ entry () returns (ptr); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl mail_system_$get_address_pathname entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mail_system_$get_address_type entry (pointer, fixed bin (17), fixed bin (35)); dcl mail_system_$get_mail_table_address entry (ptr, ptr, fixed bin(35)); dcl mlsys_utils_$parse_address_text entry (char (*), ptr, fixed bin (35)); dcl timer_manager_$sleep entry (fixed bin (71), bit (2)); dcl xmail_error_$no_code entry () options (variable); dcl xmail_error_$no_print entry () options (variable); dcl xmail_get_str_ entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var); /* Static */ dcl DEFER char (5) init ("defer") int static options (constant); dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$nomatch fixed bin (35) ext static; dcl INVALID_CHARS char (12) init ("<>#()[]{}*,;") int static options (constant); dcl MLIST char (3) init ("mls") int static options (constant); dcl NAME char (18) init ("xmail_select_file_") int static options (constant); dcl SAVE char (6) init ("sv.mbx") int static options (constant); dcl USER_MAILBOX char (14) init ("") int static options (constant); dcl VALID_LENGTH fixed bin init (32) int static options (constant); MAIN: proc (); on reissue_query begin; goto RETRY (opt); end; code = 0; Dir = ""; Prefix = ""; Names_ptr, Dyn_menup, star_names_ptr, star_entry_ptr = null; N_names = 0; Selected_dir = xmail_data.mail_dir; Default_file = Default; Create, Exists = "0"b; new_ok = New_ok; old_ok = Old_ok; if ^new_ok & ^old_ok then do; code = error_table_$bad_arg; call xmail_error_$no_code (code, NAME, "c", "Cannot choose new or old file." || "^/This is an internal error."); goto EXIT; end; Area_ptr = get_system_free_area_ (); on condition (cleanup) call CLEANUP; starname = "**." || Suffix; Cant_get_list = "0"b; call get_candidates (Selected_dir, starname, Names_ptr, N_names, code); if code = error_table_$nomatch then ; /* Process this later */ else if code ^= 0 then do; Cant_get_list = "1"b; code = 0; end; if ^new_ok /* Must have at least 1 old file */ then do; if code = error_table_$nomatch /* No old files found */ then do; call xmail_error_$no_code (0, NAME, "c", "You do not have any ^as.", File_type); goto EXIT; end; else if N_names = 1 /* One old file found, choose it automatically */ then do; Prefix = rtrim (Names (1)); Dir = Selected_dir; if Suffix = SAVE | Suffix = MLIST | Suffix = DEFER /* Print msg only for certain files */ then do; Exists = "1"b; call ioa_ ("The ^a ""^a"" automatically selected - it is your only one.", File_type, Prefix); call timer_manager_$sleep (5, "11"b); end; goto EXIT; end; end; if Own_msg then Prompt = get_caller_msg (); else Prompt = get_default_msg (); selecting = "1"b; do while (selecting); RETRY (1): opt = 1; Selected_file = ""; if xmail_data.lists_as_menus & old_ok then call get_menu_choice (Selected_file); /* always list as menu */ else do; call xmail_get_str_ (Prompt, "", PROMPT_REPLIES_HELP, explain_question (), response); if response = "" then Selected_file = Default_file; else if response = "??" then do; if old_ok then call get_menu_choice (Selected_file); /* wants to choose from menu */ else call list (); /* just wants list */ end; else if search (response, INVALID_CHARS) ^= 0 then do; /* filter garbage */ call ioa_ ("The character ""^a"" is invalid in a ^a name.", substr (response, search (response, INVALID_CHARS), 1), File_type); Selected_file = ""; end; else if length (response) > (VALID_LENGTH - length (Suffix) - 1) then do; /* check length of response */ call ioa_ ("The ""^a"" name is too long", File_type); Selected_file = ""; end; else Selected_file = response; end; if Selected_file ^= "" /* we have chosen a file */ then do; call validate_file (Selected_file, Exists, code); if code = 0 then do; Prefix = rtrim (Selected_file); Dir = Selected_dir; selecting = "0"b; end; end; end; /* do while */ EXIT: call CLEANUP; return; end MAIN; get_candidates: proc (dir, starname, names_ptr, n_names, code); /* Automatic */ dcl exclude_map (500) bit (1); dcl i fixed bin; dcl j fixed bin; dcl seg_name char (32); /* Based */ dcl names (n_names) char (32) based (names_ptr); /* Entries */ dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); /* Parameter */ dcl code fixed bin (35); dcl dir char (*); dcl n_names fixed bin; dcl names_ptr ptr; dcl starname char (*); j = 0; code = 0; call hcs_$star_ (dir, starname, star_ALL_ENTRIES, Area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 /* no match or other error */ then return; do i = 1 to star_entry_count; if exclude_this_segment (star_names (star_entries (i).nindex)) then exclude_map (i) = "1"b; else do; exclude_map (i) = "0"b; n_names = n_names + 1; end; end; allocate names in (Based_area) set (names_ptr); do i = 1 to star_entry_count; seg_name = star_names (star_entries (i).nindex); if ^exclude_map (i) then do; j = j + 1; names (j) = minus_suffix (seg_name, Suffix); end; end; end get_candidates; minus_suffix: proc (name, suffix) returns (char (*) var); /* Automatic */ dcl reverse_name char (length (name)) var; dcl reverse_suffix char (length (suffix)) var; /* Builtin */ dcl (after, index, length, reverse, rtrim) builtin; /* Parameter */ dcl name char (*); dcl suffix char (*); reverse_name = reverse (rtrim (name)); reverse_suffix = reverse (rtrim (suffix)); if index (reverse_name, reverse_suffix || ".") ^= 1 then return (name); else return (reverse (after (reverse_name, reverse_suffix || "."))); end minus_suffix; get_default_msg: proc () returns (char (256) var); /* Automatic */ dcl prompt char (256) var; if new_ok & old_ok then call ioa_$rsnnl ("Enter a new or existing ^a name" || /* Msg for both new and old */ "^[ (for ""^a"", press RETURN)^]: ", prompt, (0), File_type, Default_file ^= "", Default_file); else call ioa_$rsnnl ("Enter the name of ^[a new^;an existing^] ^a" || /* Msg for either new or old */ "^[ (for ""^a"", press RETURN)^]: ", prompt, (0), new_ok, File_type, Default_file ^= "", Default_file); return (prompt); end get_default_msg; get_caller_msg: proc () returns (char (256) var); /* Automatic */ dcl prompt char (256) var; call ioa_$rsnnl ("^a^[ (for ""^a"" press RETURN)^]: ", prompt, (0), Caller_message, Default_file ^= "", Default_file); return (prompt); end get_caller_msg; get_menu_choice: proc (filename); /* Automatic */ dcl code fixed bin (35); dcl filename char (*); dcl index fixed bin; dcl selected_create bit (1) aligned; /* Builtin */ dcl null builtin; /* Entries */ dcl xmail_dyn_menu_$create entry ((*) char (*) aligned, ptr, ptr, ptr, fixed bin (35)); dcl xmail_error_$no_code entry () options (variable); dcl xmail_dyn_menu_$create_w_trailer entry ((*) char (*) aligned, char (*), ptr, ptr, ptr, fixed bin (35)); dcl xmail_get_dyn_choice_ entry (ptr, fixed bin, fixed bin (35)); dcl xmail_get_dyn_choice_$trailer entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); filename = ""; if Cant_get_list then do; if xmail_data.lists_as_menus /* interrupt if auto menu */ then call xmail_error_$no_code (0, NAME, "i", "Unable to get a list of your ^as.", File_type); else call xmail_error_$no_code (0, NAME, "c", "Unable to get a list of your ^as.", File_type); return; end; /* If there are no menu items, a new file is allowed, and Display Lists As Menus option is yes, allow caller to create */ if N_names = 0 & new_ok & xmail_data.lists_as_menus then do; filename = ""; old_ok = "0"b; Default_file = ""; Prompt = get_default_msg (); Create = "1"b; /* caller should create */ return; end; if N_names = 0 & ^xmail_data.foreign_mailbox then do; call xmail_error_$no_code (0, NAME, "c", "You have no existing ^as.", File_type); if xmail_data.lists_as_menus /* delay if automatic list */ then call timer_manager_$sleep (5, "11"b); return; end; if new_ok then call xmail_dyn_menu_$create_w_trailer (Names, "", Dyn_menup, null, Area_ptr, code); else if xmail_data.foreign_mailbox then if N_names > 0 then call xmail_dyn_menu_$create_w_trailer (Names, "", Dyn_menup, null, Area_ptr, code); else do; N_names = 1; allocate Names in (Based_area) set (Names_ptr); Names (1) = ""; call xmail_dyn_menu_$create (Names, Dyn_menup, null, Area_ptr, code); end; else call xmail_dyn_menu_$create (Names, Dyn_menup, null, Area_ptr, code); if code ^= 0 then do; if xmail_data.lists_as_menus then call xmail_error_$no_code (code, NAME, "i", "Unable to select a ^a via a menu.", File_type); else call xmail_error_$no_code (code, NAME, "c", "Unable to select a ^a via a menu.", File_type); return; end; do while ("1"b); selected_create = "0"b; if new_ok | xmail_data.foreign_mailbox then call xmail_get_dyn_choice_$trailer (Dyn_menup, index, selected_create, code); else call xmail_get_dyn_choice_ (Dyn_menup, index, code); if code ^= 0 then do; call xmail_error_$no_code (code, NAME, "c", "Unable to use your ""^a"" selection.^/This is an internal error.", File_type); if xmail_data.lists_as_menus /* delay if automatic list */ then call timer_manager_$sleep (5, "11"b); end; else do; if selected_create then do; if new_ok then do; filename = ""; old_ok = "0"b; Default_file = ""; Prompt = get_default_msg (); Create = "1"b; /* caller should create */ end; else if xmail_data.foreign_mailbox then filename = USER_MAILBOX; end; else filename = Names (index); end; return; end; /* do while */ end get_menu_choice; list: proc (); /* Automatic */ dcl index fixed bin; /* Builtin */ dcl mod builtin; /* Entries */ dcl ioa_ entry () options (variable); dcl ioa_$nnl entry () options (variable); dcl xmail_error_$no_code entry () options (variable); if Cant_get_list then do; call xmail_error_$no_code (0, NAME, "c", "Unable to get a list of your ^as.", File_type); return; end; if N_names = 0 then do; call xmail_error_$no_code (0, NAME, "c", "You have no existing ^as.", File_type); return; end; call ioa_ ("^/You have ^d ^as:", N_names, File_type); do index = 1 to N_names; if (mod (index, 3) = 0) then call ioa_$nnl ("^a^/", Names (index)); else call ioa_$nnl ("^26a", Names (index)); end; call ioa_ ("^/"); end list; validate_file: proc (prefix, exists, code); /* Automatic */ dcl filename char (32); dcl link_type bit (1) aligned; dcl entry_type char (32); dcl type fixed bin (2); /* Builtin */ dcl rtrim builtin; /* Entries */ dcl fs_util_$get_type entry (char(*), char(*), char(*), fixed bin(35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl xmail_error_$no_code entry () options (variable); /* Parameter */ dcl code fixed bin (35); dcl exists bit (1) aligned; dcl prefix char (*); /* Static */ dcl error_table_$dirseg fixed bin (35) ext static; dcl error_table_$namedup fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$no_info fixed bin (35) ext static; dcl LINK fixed bin (2) init (0) int static options (constant); dcl NO_CHASE fixed bin (1) init (0) int static options (constant); dcl SEGMENT fixed bin (2) init (1) int static options (constant); code = 0; if Suffix = "" then filename = prefix; else filename = rtrim (prefix) || "." || Suffix; if exclude_this_segment (filename) then do; code = error_table_$noentry; call xmail_error_$no_code (code, NAME, "c", "This name must be excluded from your choice. ""^a""", prefix); goto EXIT_VALIDATE; end; link_type = "0"b; call hcs_$status_minf (Selected_dir, filename, NO_CHASE, type, (0), code); if (code = 0) & (type = LINK) then do; call fs_util_$get_type (Selected_dir, filename, entry_type, code); link_type = "1"b; end; if code = error_table_$noentry /* Process this later */ then do; exists = "0"b; if link_type /* Check for inconsistency */ then do; call xmail_error_$no_code (code, NAME, "c", "Unable to use the ^a ""^a"" because of an inconsistency in your xmail directory." || "^/A link points to nowhere.", File_type, prefix); if xmail_data.lists_as_menus /* delay if automatic list */ then call timer_manager_$sleep (5, "11"b); goto EXIT_VALIDATE; end; end; else if code = error_table_$no_info then do; call xmail_error_$no_code (code, NAME, "c", " You do not have access to use the ""^a"" ^a.", prefix, File_type); if xmail_data.lists_as_menus /* delay if automatic list */ then call timer_manager_$sleep (5, "11"b); goto EXIT_VALIDATE; end; else if code ^= 0 then do; call xmail_error_$no_code (code, NAME, "c", "Unable to use the ^a ""^a"".^/This is an internal error.", File_type, prefix); if xmail_data.lists_as_menus /* delay if automatic list */ then call timer_manager_$sleep (5, "11"b); goto EXIT_VALIDATE; end; else exists = "1"b; /* code = 0 */ if new_ok & old_ok /* accept any name NEW or OLD */ then do; code = 0; goto EXIT_VALIDATE; end; if new_ok /* Need a NEW file name */ then do; if code = error_table_$noentry then do; code = 0; goto EXIT_VALIDATE; end; else do; code = error_table_$namedup; call xmail_error_$no_code (code, NAME, "c", "The ^a name ""^a"" is already used." || "^/Please specify another name.", File_type, prefix); goto EXIT_VALIDATE; end; end; if code = error_table_$noentry /* Must be OLD file */ then do; if ^xmail_data.foreign_mailbox then call xmail_error_$no_code (code, NAME, "c", "Unable to use the ^a ""^a""." || " It does not exist.", File_type, prefix); goto EXIT_VALIDATE; end; if (type ^= SEGMENT & entry_type ^= "mbx") then do; code = error_table_$dirseg; call xmail_error_$no_code (code, NAME, "c", "Unable to use ""^a"".^/It is not of expected type (^a)." || " This is an inconsistency in your xmail directory.", prefix, File_type); if xmail_data.lists_as_menus /* delay if automatic list */ then call timer_manager_$sleep (5, "11"b); end; EXIT_VALIDATE: return; end validate_file; explain_question: proc returns (char (32) var); /* Automatic */ dcl info_name char (32) var; /* Builtin */ dcl translate builtin; call ioa_$rsnnl ("^[^4s^;^[^a^x^2s^;^s^[^a^x^;^s^]^]^]^a", info_name, (0), new_ok & old_ok, new_ok, "new", old_ok, "old", File_type); info_name = translate (info_name, "_", " "); return (info_name); end explain_question; exclude_this_segment: proc (seg_name) returns (bit (1) aligned); /* Automatic */ dcl exclude_flag bit (1) aligned; dcl i fixed bin; dcl match_code fixed bin (35); /* Entry */ dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); /* Builtin */ dcl hbound builtin; /* Parameter */ dcl seg_name char (*); exclude_flag = "0"b; if Suffix = "mbx" then do; call match_star_name_ (seg_name, "**.sv.mbx", match_code); if match_code = 0 then do; exclude_flag = "1"b; goto EXCLUDE_EXIT; end; end; if ^Excluding_some_names then goto EXCLUDE_EXIT; do i = 1 to hbound (Exclude_array, 1); if seg_name = Exclude_array (i) then do; exclude_flag = "1"b; goto EXCLUDE_EXIT; end; end; EXCLUDE_EXIT: return (exclude_flag); end exclude_this_segment; CLEANUP: proc (); dcl xmail_dyn_menu_$free entry (ptr, fixed bin (35)); dcl cleanup_code fixed bin (35); if star_names_ptr ^= null () then free star_names;/* order is important */ if star_entry_ptr ^= null () then free star_entries; if Names_ptr ^= null () then free Names; if Dyn_menup ^= null () then do; call xmail_dyn_menu_$free (Dyn_menup, cleanup_code); if cleanup_code ^= 0 then call xmail_error_$no_print (cleanup_code, NAME, "c", "Unable to free the dynamic menu."); end; end CLEANUP; /* Include */ %include xmail_data; %page; %include xmail_help_infos; %page; %include star_structures; %page; %include mlsys_address_types; end xmail_select_file_;  xmail_select_msgs_.pl1 09/02/88 0759.6r w 09/02/88 0745.0 395892 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-02-06,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): 85-02-28 JG Backs: Modified to allow selection of messages by date or range of dates. Added 3 new internal procedures to do this: date_search, convert_date, and date_current. Also added an include file for date conversions: time_value.incl.pl1 and clock builtin. 85-03-11 JG Backs: Modified to allow responses of short forms of keywords. Allow a for all, l for last, f for first, n for next, and p for prev. Include file xmail_responses.incl.pl1 was also modified to add short forms. 2) change(86-02-06,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Add new procs to process "new", "seen", and "unseen" selection specifiers. Note that the previous meaning of "new" is preserved in the new_current procedure whereas the new meaning of "new" (unseen since last seen) requires a new entrypoint. The old is retained so that xmail_Process_Mail_ can update mail file counts as new messages arrive. 3) change(86-02-25,Blair), approve(86-02-25,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Change the interpret_list routine so that swn seen and swf seen can be processed. This required changes to when the message structure gets allocated for SEEN UNSEEN NEW and ALL messages. It is now possible to process lists of messages in conjunction with ranges. 4) change(87-01-14,Blair), approve(87-02-05,MCR7618), audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025): Initialize the count variable in new_current to alleviate a size error problem when we create a new current msgs structure. END HISTORY COMMENTS */ xmail_select_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_seen_msgs, P_switch_on_off, P_pos_line); /* BEGIN DESCRIPTION history: Created 06/17/81 by Suzanne Krupp 83-07-14 DJ Schimke: Modified to use new mail_system calls and version 2 mailboxes. 84-11-09 JG Backs: Modified interpret_range internal procedure to make sure the largest number in the range is not above the number of messages in the mailbox. END DESCRIPTION */ /* PARAMETERS */ dcl P_curr_msgsp ptr parameter; dcl P_deleted_msgsp ptr parameter; dcl P_mailbox_ptr ptr parameter; dcl P_pos_line char (*) parameter; dcl P_spec_msgsp ptr parameter; dcl P_switch_on_off bit (2) aligned parameter; dcl P_seen_msgs ptr; /* AUTOMATIC */ dcl area_ptr ptr; dcl code fixed bin (35); dcl hold_code fixed bin (35); dcl i fixed bin; dcl line char (256) var; dcl list_any bit (1) aligned; dcl need_answer bit (1) aligned; dcl n_new_msgs fixed bin; dcl prompt_sw bit (1) aligned; dcl switch_on bit (1) aligned; dcl switch_off bit (1) aligned; dcl unused_return_length fixed bin; dcl want_deleted_msgs bit (1) aligned; dcl want_seen_messages bit (1) aligned; /* BASED */ dcl based_area area based (area_ptr); /* BUILTINS */ dcl (addr, after, before, char, index, length, ltrim, null, rtrim, verify) builtin; /* CONDITIONS */ dcl cleanup condition; /* CONSTANTS */ dcl DUMMY_ANSWER_ARRAY (1) char (1) var static options (constant) init (""); dcl ME_CHAR char (17) int static options (constant) init ("xmail_select_msgs"); dcl ONE_DAY fixed binary (71) static options (constant) init (86399999999); /* one microsecond less than 1 day */ dcl SECONDS bit (2) int static options (constant) init ("11"b); dcl TODAY char (5) int static options (constant) init ("today"); /* ENTRIES */ dcl com_err_$suppress_name entry () options (variable); dcl convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin(35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var); dcl date_time_$from_clock entry (fixed bin(71), char(*), ptr, fixed bin(35)); dcl date_time_$to_clock entry (ptr, fixed bin(71), fixed bin(35)); dcl get_system_free_area_ entry () returns (ptr); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl mail_system_$read_message entry (ptr, fixed bin, fixed bin (35)); dcl mail_system_$read_new_messages entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl mlsys_utils_$search_message entry (ptr, char (*), ptr, fixed bin (35)) returns (bit (1) aligned); dcl timer_manager_$sleep entry (fixed bin(71), bit(2)); dcl xmail_error_$code_first entry () options (variable); dcl xmail_error_$no_code entry () options (variable); dcl xmail_get_str_ entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var); dcl xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); dcl xmail_list_msgs_ entry (ptr, ptr, ptr); dcl xmail_list_msgs_$selected entry (ptr, ptr, ptr); dcl xmail_validate_$curr_msgs entry (ptr, fixed bin (35)); dcl xmail_validate_$mbx entry (ptr, fixed bin (35)); /* EXTERNAL STATIC */ dcl (mlsys_et_$no_more_messages, xmail_err_$bad_response, xmail_err_$int_prog_err, xmail_err_$invalid_list, xmail_err_$invalid_range, xmail_err_$list_requested, xmail_err_$mailbox_empty, xmail_err_$no_msgs_exist, xmail_err_$some_del_msgs_exist, xmail_err_$some_msgs_exist, xmail_err_$date_not_found, xmail_err_$str_not_found) fixed bin (35) ext static; dcl iox_$user_output ptr ext static; /* INCLUDE FILES */ %page; %include mlsys_message; %page; %include mlsys_mailbox; %page; %include time_value; %page; %include xmail_curr_msg_info; %page; %include xmail_prompts; %page; %include xmail_responses; %page; %include xmail_help_infos; %page; %include mlsys_search_options; %page; %include xmail_data; /* Initialization */ want_deleted_msgs, want_seen_messages, switch_on, switch_off, list_any = "0"b; P_switch_on_off = "00"b; P_seen_msgs = null; call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line); need_answer = "1"b; do while (need_answer); call xmail_get_str_ ((MSG_SELECT_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, MSG_SELECT_INFO, line); code, count = 0; curr_msgsp, nonexist_msgsp = null; /* Look to see if more messages are in the mailbox. */ call mail_system_$read_new_messages (mailbox_ptr, n_new_msgs, (0), (0), code); if code ^= 0 & code ^= mlsys_et_$no_more_messages then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to look for new messages. This is an internal programming error."); hold_code = code; code = 0; if line = A | line = ALL | line = SEEN | line = UNSEEN | line = NEW then call alloc_msg_struct (mailbox.n_messages, curr_msgsp); if line = ALL | line = A then call all_current (count); else if line = FIRST | line = F then call first_current (); else if line = LAST | line = L then call last_current (); else if line = NEXT | line = N then call next_current (P_curr_msgsp); else if line = PREV | line = P then call prev_current (P_curr_msgsp); else if line = NEW then call new_since_last_seen (count); else if line = SEARCH then call search (code); else if line = SEEN then call seen_current (count); else if line = UNSEEN then call unseen_current (count); else if line = DATE then call date_search (code); /* else if index (line, ":") > 0 then call interpret_range (line, code); else if verify (line, "0123456789 ") = 0 then call interpret_list (line, code); */ else if line = LIST then code = xmail_err_$list_requested; else call interpret_list (line,code); if code = 0 /* Everything ok */ then do; if line = A | line = ALL | line = NEW | line = SEEN | line = UNSEEN then curr_msgs.count = count; need_answer = "0"b; if ^(switch_on | switch_off) then call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, curr_msgs.numbers); end; else if code = xmail_err_$list_requested /* User wanted a list */ then do; call ioa_ ("^/^a", MSG_LIST_MSG); call xmail_list_msgs_ (mailbox_ptr, P_curr_msgsp, iox_$user_output); end; else do; /* Something went wrong */ call com_err_$suppress_name (code, ME_CHAR); if code = xmail_err_$some_msgs_exist then do; if want_some () then do; need_answer = "0"b; call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, curr_msgs.numbers); end; end; else if code ^= xmail_err_$invalid_range & code ^= xmail_err_$invalid_list & code ^= xmail_err_$no_msgs_exist & code ^= xmail_err_$str_not_found & code ^= xmail_err_$date_not_found & code ^= xmail_err_$bad_response then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to interpret response. This is an internal programming error."); end; if need_answer /* get rid of what we don't need. */ then if curr_msgsp ^= null then free curr_msgs; if nonexist_msgsp ^= null then free nonexist_msgs; end; /* do while */ if switch_on | switch_off then P_seen_msgs = curr_msgsp; else call use_spec_msgs (P_curr_msgsp, curr_msgsp); if switch_on then P_switch_on_off = "10"b; if switch_off then P_switch_on_off = "01"b; return; /* ENTRYPOINTS */ all: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line); dcl msg_count fixed bin; want_deleted_msgs = "0"b; msg_count = 0; call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line); call alloc_msg_struct (mailbox.n_messages, curr_msgsp); call all_current (msg_count); P_pos_line = "all"; call use_spec_msgs (P_curr_msgsp, curr_msgsp); return; /* all */ new: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line); want_deleted_msgs = "0"b; call xmail_validate_$mbx (P_mailbox_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error."); if P_curr_msgsp ^= null then do; call xmail_validate_$curr_msgs (P_curr_msgsp, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error."); end; mailbox_ptr = P_mailbox_ptr; area_ptr = get_system_free_area_ (); if mailbox.n_messages = 0 then do; call use_spec_msgs (P_curr_msgsp, null); P_pos_line = "NONE"; call xmail_error_$code_first (xmail_err_$mailbox_empty, ME_CHAR, "i"); end; call mail_system_$read_new_messages (mailbox_ptr, n_new_msgs, (0), (0), code); if code ^= 0 & code ^= mlsys_et_$no_more_messages then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to look for new messages. This is an internal programming error."); call new_current (n_new_msgs, code); call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, curr_msgs.numbers); /* P_pos_line = "newly arrived"; */ call use_spec_msgs (P_curr_msgsp, curr_msgsp); return; /* first */ first: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line); want_deleted_msgs = "0"b; call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line); call first_current (); P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1)))); call use_spec_msgs (P_curr_msgsp, curr_msgsp); return; /* first */ last: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line); want_deleted_msgs = "0"b; call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line); call last_current (); P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1)))); call use_spec_msgs (P_curr_msgsp, curr_msgsp); return; /* last */ next: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line); want_deleted_msgs = "0"b; call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line); call next_current (P_curr_msgsp); P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1)))); call use_spec_msgs (P_curr_msgsp, curr_msgsp); return; /* next */ prev: entry (P_mailbox_ptr, P_curr_msgsp, P_pos_line); want_deleted_msgs = "0"b; call init (P_mailbox_ptr, P_curr_msgsp, P_pos_line); call prev_current (P_curr_msgsp); P_pos_line = ltrim (rtrim (char (curr_msgs.numbers (1)))); call use_spec_msgs (P_curr_msgsp, curr_msgsp); return; /* prev */ deleted: entry (P_mailbox_ptr, P_deleted_msgsp, P_flavor); dcl P_flavor char (*) parameter; dcl count fixed bin; count = 0; want_deleted_msgs = "1"b; switch_on, switch_off = "0"b; P_deleted_msgsp = null; call xmail_validate_$mbx (P_mailbox_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error."); if P_deleted_msgsp ^= null then do; call xmail_validate_$curr_msgs (P_deleted_msgsp, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error."); end; mailbox_ptr = P_mailbox_ptr; area_ptr = get_system_free_area_ (); if mailbox.n_deleted_messages <= 0 then do; if ^xmail_data.cleanup_signalled then call ioa_ ("There are no discarded messages."); P_deleted_msgsp = null (); return; end; if P_flavor ^= "" then do; line = P_flavor; prompt_sw = "0"b; end; else prompt_sw = "1"b; need_answer = "1"b; do while (need_answer); if xmail_data.cleanup_signalled then do; prompt_sw = "0"b; line = ALL; end; if prompt_sw then call xmail_get_str_ ((DEL_MSG_SELECT_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, DEL_MSG_SELECT_INFO, line); prompt_sw = "1"b; code = 0; curr_msgsp, nonexist_msgsp = null; if line = ALL | line = A | line = NEW | line = SEEN | line = UNSEEN then call alloc_msg_struct (mailbox.n_messages, curr_msgsp); if line = ALL | line = A then do; count = 0; call all_current (count); curr_msgs.count = count; end; else if line = FIRST | line = F then call first_current (); else if line = LAST | line = L then call last_current (); /* else if index (line, ":") > 0 then call interpret_range (line, code); else if verify (line, "0123456789 ") = 0 then call interpret_list (line, code); */ else if line = LIST then code = xmail_err_$list_requested; else call interpret_list (line,code); if code = 0 then need_answer = "0"b; else if code = xmail_err_$list_requested then do; /* User requested a list */ count = 0; call alloc_msg_struct (mailbox.n_messages, curr_msgsp); call all_current (count); curr_msgsp -> curr_msgs.count = count; call ioa_ ("^/^a^/", DEL_MSG_LIST_MSG); call xmail_list_msgs_$selected (mailbox_ptr, curr_msgsp, iox_$user_output); end; else do; call com_err_$suppress_name (code, ME_CHAR); if code = xmail_err_$some_del_msgs_exist then do; if want_some () then need_answer = "0"b; end; else if code ^= xmail_err_$invalid_range & code ^= xmail_err_$invalid_list & code ^= xmail_err_$no_msgs_exist & code ^= xmail_err_$bad_response then call xmail_error_$no_code (code, ME_CHAR, "q", "Unable to interpret user response. This is an internal programming error."); end; if need_answer then if curr_msgsp ^= null then free curr_msgs; if nonexist_msgsp ^= null then free nonexist_msgs; end; P_deleted_msgsp = curr_msgsp; return; /* deleted */ replace_curr: entry (P_curr_msgsp, P_spec_msgsp, P_pos_line); call use_spec_msgs (P_curr_msgsp, P_spec_msgsp); call ioa_$rsnnl ("^(^d ^)", P_pos_line, unused_return_length, P_curr_msgsp -> curr_msgs.numbers); return; /* replace_curr */ /* INTERNAL PROCEDURES */ init: proc (P_mailbox_ptr, P_curr_msgsp, P_pos_line); dcl (P_mailbox_ptr, P_curr_msgsp) ptr; dcl P_pos_line char (*); dcl code fixed bin (35); call xmail_validate_$mbx (P_mailbox_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid mailbox structure. This is an internal programming error."); if P_curr_msgsp = null then ; else do; call xmail_validate_$curr_msgs (P_curr_msgsp, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "q", "Invalid message structure. This is an internal programming error."); end; mailbox_ptr = P_mailbox_ptr; area_ptr = get_system_free_area_ (); if mailbox.n_messages = 0 then do; call use_spec_msgs (P_curr_msgsp, null); P_pos_line = "NONE"; go to INIT_EXIT; end; if mailbox.n_messages <= mailbox.n_deleted_messages then do; call use_spec_msgs (P_curr_msgsp, null); P_pos_line = "NONE"; call xmail_error_$no_code (code, ME_CHAR, "i"); end; INIT_EXIT: return; end init; all_current: proc (P_count); dcl P_count fixed bin; dcl i, count fixed bin; count = P_count; do i = 1 to mailbox.n_messages; if want_deleted_msgs = msg_deleted (i) then if ^already_specified (i, curr_msgsp) then call add_to_msg_struct (curr_msgsp, count, i); end; P_count = count; end all_current; first_current: proc (); call alloc_msg_struct (1, curr_msgsp); if want_deleted_msgs then curr_msgs.numbers (1) = first_deleted (); else curr_msgs.numbers (1) = first_existing (); end first_current; last_current: proc (); call alloc_msg_struct (1, curr_msgsp); if want_deleted_msgs then curr_msgs.numbers (1) = last_deleted (); else curr_msgs.numbers (1) = last_existing (); end last_current; next_current: proc (P_curr_msgsp); dcl P_curr_msgsp ptr; dcl found bit (1) aligned; dcl (i, highest) fixed bin; highest = 0; if P_curr_msgsp ^= null then do i = 1 to P_curr_msgsp -> curr_msgs.count; if highest < P_curr_msgsp -> curr_msgs.numbers (i) then highest = P_curr_msgsp -> curr_msgs.numbers (i); end; call alloc_msg_struct (1, curr_msgsp); found = "0"b; do i = highest + 1 to mailbox.n_messages while (^found); if ^msg_deleted (i) then do; curr_msgs.numbers (1) = i; found = "1"b; end; end; do i = 1 to highest while (^found); if ^msg_deleted (i) then do; curr_msgs.numbers (1) = i; found = "1"b; end; end; end next_current; prev_current: proc (P_curr_msgsp); dcl P_curr_msgsp ptr; dcl found bit (1) aligned; dcl (i, lowest) fixed bin; lowest = mailbox.n_messages + 1; if P_curr_msgsp ^= null then do i = 1 to P_curr_msgsp -> curr_msgs.count; if lowest > P_curr_msgsp -> curr_msgs.numbers (i) then lowest = P_curr_msgsp -> curr_msgs.numbers (i); end; call alloc_msg_struct (1, curr_msgsp); found = "0"b; do i = lowest - 1 to 1 by -1 while (^found); if ^msg_deleted (i) then do; curr_msgs.numbers (1) = i; found = "1"b; end; end; do i = mailbox.n_messages to lowest by -1 while (^found); if ^msg_deleted (i) then do; curr_msgs.numbers (1) = i; found = "1"b; end; end; end prev_current; new_current: proc (P_new_msgs, P_code); dcl P_code fixed bin (35); dcl count fixed bin; dcl i fixed bin; dcl P_new_msgs fixed bin; if P_code = mlsys_et_$no_more_messages then call xmail_error_$code_first (P_code, ME_CHAR, "i"); call alloc_msg_struct (P_new_msgs, curr_msgsp); count = 0; do i = mailbox.n_messages - P_new_msgs + 1 to mailbox.n_messages; call mail_system_$read_message (mailbox_ptr, i, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is a n internal programming error.", i); /* message_ptr = mailbox.messages (i). message_ptr; */ call add_to_msg_struct (curr_msgsp, count, i); end; end new_current; new_since_last_seen: proc (P_count); dcl P_count fixed bin; dcl (count, i, first_unseen, last_seen) fixed bin; want_seen_messages = "0"b; count = P_count; do i = mailbox.n_messages by -1 to 1 while (want_seen_messages = msg_seen (i)); end; last_seen = i; if last_seen < mailbox.n_messages then do; first_unseen = last_seen +1; do i = first_unseen to mailbox.n_messages; if ^already_specified (i, curr_msgsp) then call add_to_msg_struct (curr_msgsp, count, i); end; end; P_count = count; if count = 0 then call xmail_error_$no_code ((0), ME_CHAR, "i", "There are no ""new"" messages in this mailbox."); end new_since_last_seen; seen_current: proc(P_count); dcl P_count fixed bin; dcl (count,i) fixed bin; want_seen_messages = "1"b; count = P_count; do i = 1 to mailbox.n_messages; if want_seen_messages = msg_seen(i) then if ^already_specified (i, curr_msgsp) then call add_to_msg_struct (curr_msgsp, count, i); end; P_count = count; if count = 0 then call xmail_error_$no_code ((0),ME_CHAR,"i","There are no ""seen"" messages in this mailbox."); end seen_current; unseen_current: proc (P_count); dcl P_count fixed bin; dcl (count,i) fixed bin; want_seen_messages = "0"b; count = P_count; do i = 1 to mailbox.n_messages; if want_seen_messages = msg_seen (i) then if ^already_specified (i, curr_msgsp) then call add_to_msg_struct (curr_msgsp, count ,i); end; P_count = count; if count = 0 then call xmail_error_$no_code ((0), ME_CHAR, "i", "There are no ""unseen"" messages in this mailbox."); end unseen_current; interpret_range: proc (P_str,P_left_num, P_right_num, P_code); dcl P_str char (*) var; dcl P_left_num fixed bin; dcl P_right_num fixed bin; dcl P_code fixed bin (35); dcl (curr_count, nonexist_count) fixed bin; dcl (left_num, right_num) fixed bin; dcl (left_str, right_str) char (length (P_str)) var; dcl code fixed bin (35); P_code = 0; left_str = ltrim (rtrim (before (P_str, ":"))); right_str = ltrim (rtrim (after (P_str, ":"))); if left_str = "" | right_str = "" then do; P_code = xmail_err_$invalid_range; go to RANGE_EXIT; end; left_num = get_num ((left_str), code); if code ^= 0 then do; P_code = xmail_err_$invalid_range; go to RANGE_EXIT; end; right_num = get_num ((right_str), code); if code ^= 0 then do; P_code = xmail_err_$invalid_range; go to RANGE_EXIT; end; if left_num > right_num then do; P_code = xmail_err_$invalid_range; go to RANGE_EXIT; end; /* None of the specified messages exist. */ if right_num < 1 | left_num > mailbox.n_messages then do; P_code = xmail_err_$no_msgs_exist; go to RANGE_EXIT; end; /* Test if right number is more that the total messages */ if right_num > mailbox.n_messages then do; P_code = xmail_err_$invalid_range; go to RANGE_EXIT; end; P_left_num = left_num; P_right_num = right_num; if ^list_any then do; curr_count, nonexist_count = 0; call alloc_msg_struct (right_num - left_num + 1, curr_msgsp); call alloc_msg_struct (right_num - left_num + 1, nonexist_msgsp); do i = left_num to right_num; if want_deleted_msgs = msg_deleted (i) then call add_to_msg_struct (curr_msgsp, curr_count, i); else call add_to_msg_struct (nonexist_msgsp, nonexist_count, i); end; call set_counts (curr_count, nonexist_count, P_code); end; RANGE_EXIT: return; end interpret_range; interpret_list: proc (P_str, P_code); dcl P_str char (*) var; dcl P_code fixed bin (35); dcl (copy_str) char (length (P_str)) var; dcl (curr_count, nonexist_count) fixed bin; dcl (msg_num, n_tokens, token_index) fixed bin; dcl code fixed bin (35); dcl first_token fixed bin; dcl now_in_struct bit (1) aligned; dcl have_range bit (1) aligned; dcl left_num fixed bin; dcl right_num fixed bin; dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl token_array_ptr ptr; dcl 1 token_array based (token_array_ptr) aligned, 2 Ntokens fixed bin, 2 token (0 refer (Ntokens)) char (10) var; token_array_ptr = null; have_range = "0"b; list_any = "1"b; left_num, right_num, n_tokens, first_token = 0; P_code, code = 0; copy_str = P_str; call get_temp_segment_ (ME_CHAR, token_array_ptr, code); if code ^= 0 then do; code = xmail_err_$int_prog_err; goto LIST_EXIT; end; on cleanup begin; if token_array_ptr ^= null then call release_temp_segment_ (ME_CHAR, token_array_ptr, (0)); end; Ntokens = 1; token_array.token(Ntokens) = next_token (copy_str); do while (token_array.token(Ntokens) ^= ""); if index (token_array.token(Ntokens) ,":") > 0 then do; call interpret_range ((token_array.token(Ntokens)), left_num, right_num, P_code); if P_code ^= 0 then goto LIST_EXIT; n_tokens = n_tokens + (right_num - left_num); end; Ntokens = Ntokens + 1; token_array.token(Ntokens) = next_token (copy_str); end; /* what have we got here? */ first_token = 1; if token_array.token(1) = "switch_on" | token_array.token(1) = "swn" then if token_array.token(2) = SEEN then do; switch_on = "1"b; if Ntokens > 2 then first_token = 3; end; else do; P_code = xmail_err_$bad_response; goto LIST_EXIT; end; if token_array.token(1) = "switch_off" | token_array.token(1) = "swf" then if token_array.token(2) = SEEN then do; switch_off = "1"b; if Ntokens > 2 then first_token = 3; end; else do; P_code = xmail_err_$bad_response; goto LIST_EXIT; end; if (switch_on | switch_off) then n_tokens = (Ntokens + n_tokens - 3); else n_tokens = (Ntokens + n_tokens -1); /* take off the "" */ do token_index = first_token to Ntokens; if token_array.token(token_index) = SEEN | token_array.token(token_index) = ALL | token_array.token(token_index) = A | token_array.token(token_index) = NEW | token_array.token(token_index) = UNSEEN then n_tokens = mailbox.n_messages; end; call alloc_msg_struct (n_tokens, curr_msgsp); call alloc_msg_struct (n_tokens, nonexist_msgsp); curr_count, nonexist_count = 0; do token_index = first_token to Ntokens while (token_array.token(token_index) ^= ""); now_in_struct = "0"b; if index (token_array.token(token_index), ":") > 0 /* we have a range */ then have_range = "1"b; else if token_array.token(token_index) = LAST | token_array.token(token_index) = L /* want the last msg */ then msg_num = get_num((token_array.token(token_index)), code); else if token_array.token(token_index) = FIRST | token_array.token(token_index) = F /* want the first msg */ then msg_num = get_num((token_array.token(token_index)), code); else if verify (token_array.token(token_index), "0123456789") = 0 /* single msg number */ then msg_num = cv_dec_check_ ((token_array.token(token_index)), code); else if token_array.token(token_index) = NEW then do; call new_since_last_seen (curr_count); now_in_struct = "1"b; end; else if token_array.token(token_index) = SEEN then do; call seen_current (curr_count); now_in_struct = "1"b; end; else if token_array.token(token_index) = UNSEEN then do; call unseen_current (curr_count); now_in_struct = "1"b; end; else if token_array.token(token_index) = ALL | token_array.token(token_index) = A then do; call all_current (curr_count); now_in_struct = "1"b; end; else code = xmail_err_$invalid_list; if code ^= 0 then do; P_code = xmail_err_$invalid_list; go to LIST_EXIT; end; if have_range then do msg_num = left_num to right_num; if ^already_specified (msg_num, curr_msgsp) then if want_deleted_msgs = msg_deleted (msg_num) then call add_to_msg_struct (curr_msgsp, curr_count, msg_num); else call add_to_msg_struct (nonexist_msgsp, nonexist_count ,msg_num); have_range = "0"b; end; else if ^now_in_struct & (^already_specified (msg_num, curr_msgsp)) then do; if msg_num >= 1 & msg_num <= mailbox.n_messages then do; if want_deleted_msgs = msg_deleted (msg_num) then call add_to_msg_struct (curr_msgsp, curr_count, msg_num); else call add_to_msg_struct (nonexist_msgsp, nonexist_count, msg_num); end; else call add_to_msg_struct (nonexist_msgsp, nonexist_count, msg_num); end; end; curr_msgs.count = curr_count; call set_counts (curr_count, nonexist_count, P_code); LIST_EXIT: if token_array_ptr ^= null then do; call release_temp_segment_ (ME_CHAR, token_array_ptr, (0)); token_array_ptr = null; end; return; end interpret_list; search: proc (P_code); dcl P_code fixed bin (35); dcl search_str char (256) var; P_code = 0; search_str = ""; do while (search_str = ""); call xmail_get_str_ ((SEARCH_STR_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, SEARCH_STR_INFO, search_str); end; call search_current ((search_str)); if curr_msgs.count = 0 then P_code = xmail_err_$str_not_found; return; end search; search_current: proc (P_search_str); dcl P_search_str char (*); dcl i fixed bin; dcl count fixed bin; dcl msg_has_str bit (1) aligned; dcl 1 auto_search_options like search_options; auto_search_options.version = SEARCH_OPTIONS_VERSION_2; auto_search_options.regexp_search = "0"b; auto_search_options.case_insensitive = "0"b; auto_search_options.search_envelope = "1"b; auto_search_options.search_header = "1"b; auto_search_options.search_redistributions_list = "1"b; auto_search_options.search_body = "1"b; auto_search_options.mbz = "0"b; call alloc_msg_struct (mailbox.n_messages, curr_msgsp); count = 0; do i = 1 to mailbox.n_messages; if ^msg_deleted (i) then do; if mailbox.messages (i).message_ptr = null then do; call mail_system_$read_message (mailbox_ptr, i, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", i); end; message_ptr = mailbox.messages (i).message_ptr; msg_has_str = mlsys_utils_$search_message (message_ptr, P_search_str, addr (auto_search_options), code); if code = 0 then do; if msg_has_str then call add_to_msg_struct (curr_msgsp, count, i); end; end; end; /* do i = ... */ curr_msgs.count = count; return; end search_current; date_search: proc (P_code); dcl P_code fixed bin (35); /* output */ dcl ds_ascii_date_1 char (22); /* formatted */ dcl ds_ascii_date_2 char (22); /* formatted */ dcl ds_clock_value_1 fixed bin (71); /* converted */ dcl ds_clock_value_2 fixed bin (71); /* converted */ dcl ds_date_str_1 char (256) var; /* user input */ dcl ds_date_str_2 char (256) var; /* user input */ /* BEGIN */ P_code = 0; RESTART: ds_clock_value_1 = 0; ds_clock_value_2 = 0; do while (ds_clock_value_1 = 0); ds_date_str_1 = ""; call xmail_get_str_ ((DATE_1_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, DATE_INFO, ds_date_str_1); if ds_date_str_1 = "" /* 1st date null, check 2nd */ then go to DATE2; else ds_clock_value_1 = convert_date ((ds_date_str_1)); end; DATE2: do while (ds_clock_value_2 = 0); ds_date_str_2 = ""; call xmail_get_str_ ((DATE_2_PROMPT), DUMMY_ANSWER_ARRAY, PROMPT_REPLIES_HELP, DATE_INFO, ds_date_str_2); /* If there are two dates entered, make the 2nd date with 23:59 time */ if ds_date_str_1 ^= "" & ds_date_str_2 ^= "" then do; ds_clock_value_2 = convert_date ((ds_date_str_2)); if ds_clock_value_2 ^= 0 then ds_clock_value_2 = ds_clock_value_2 + ONE_DAY; end; /* If both dates are null, use current date with 00:00 time as 1st clock date. The 2nd date will be current date with 23:59 time. */ else if ds_date_str_1 = "" & ds_date_str_2 = "" /* both null */ then do; ds_date_str_1 = TODAY; ds_clock_value_1 = convert_date ((ds_date_str_1)); if ds_clock_value_1 ^= 0 then ds_clock_value_2 = ds_clock_value_1 + ONE_DAY; /* add one day minus one microsecond to get the full day. */ end; /* If either dates are null, make the entered date the 1st clock date with 00:00 time. The 2nd clock date will be the same date with 23:59 time. */ else do; if ds_date_str_1 = "" & ds_date_str_2 ^= "" /* 1st null */ then ds_clock_value_1 = convert_date ((ds_date_str_2)); else ds_clock_value_1 = convert_date ((ds_date_str_1)); if ds_clock_value_1 ^= 0 then ds_clock_value_2 = ds_clock_value_1 + ONE_DAY; /* add one day minus one microsecond to get the full day of the 1st date */ end; end; /* do while */ /* Convert new clock values to ascii date strings for message to user */ ds_ascii_date_1 = date_time_$format ("^my/^dm/^yc ^Hd:^MH ^xxxxza", (ds_clock_value_1), "", ""); ds_ascii_date_2 = date_time_$format ("^my/^dm/^yc ^Hd:^MH ^xxxxza", (ds_clock_value_2), "", ""); if ds_clock_value_1 >= ds_clock_value_2 /* check if dates backwards */ then do; call ioa_ ("The range of ^/ ""^a"" thru ""^a"" is empty or backwards.", ds_ascii_date_1, ds_ascii_date_2); go to RESTART; end; call ioa_ ("Selecting messages from ^/ ""^a"" thru ""^a"".", ds_ascii_date_1, ds_ascii_date_2); call timer_manager_$sleep (8, SECONDS); /* let user read */ call date_current ((ds_clock_value_1), (ds_clock_value_2)); if curr_msgs.count = 0 then P_code = xmail_err_$date_not_found; return; end date_search; /* Internal function to convert a date string into a clock value and clear out the time to 00:00 (midnight). */ convert_date: proc (P_date_string) returns (fixed bin (71)); dcl P_date_string char (*); /* input */ dcl cd_clock_value fixed bin (71); /* output */ dcl cd_code fixed bin (35); cd_clock_value = 0; Ptime_value = null; /* clear ptr */ call convert_date_to_binary_ ((P_date_string), cd_clock_value, cd_code); if cd_code ^= 0 then do; call ioa_ ("There is something wrong with the date or time as entered. ^/ Try again or use ? to get help."); go to cd_EXIT; end; /* Zero out the time */ allocate time_value in (based_area); time_value.version = Vtime_value_3; call date_time_$from_clock ((cd_clock_value), "", addr (time_value), cd_code); if cd_code ^= 0 then do; call ioa_ ("There is a problem with converting the date entered. ^/ Try again or use ? to get help."); go to cd_EXIT; end; /* Zero out all but day in calendar value to get date with zero time */ time_value.yc = 0; time_value.my = 0; time_value.dm = 0; time_value.Hd = 0; time_value.MH = 0; time_value.SM = 0; time_value.US = 0; time_value.fw = 0; time_value.dw = 0; time_value.dy = 0; time_value.Uc = 0; time_value.leap_year = 0; call date_time_$to_clock (addr (time_value), cd_clock_value, cd_code); if cd_code ^= 0 then do; call ioa_ ("There is a problem with converting the date entered. ^/ Try again or use ? to get help."); go to cd_EXIT; end; cd_EXIT: if Ptime_value ^= null then free time_value; /* free if allocated */ return (cd_clock_value); end convert_date; date_current: proc (P_clock_value_1, P_clock_value_2); dcl P_clock_value_1 fixed bin (71); /* input */ dcl P_clock_value_2 fixed bin (71); /* input */ dcl i fixed bin; dcl dc_count fixed bin; call alloc_msg_struct (mailbox.n_messages, curr_msgsp); dc_count = 0; do i = 1 to mailbox.n_messages; if ^msg_deleted (i) then do; if mailbox.messages (i).message_ptr = null then do; call mail_system_$read_message (mailbox_ptr, i, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", i); end; message_ptr = mailbox.messages (i).message_ptr; /* Test if date created in message header is between 1st and 2nd date/time */ if (message.date_time_created >= P_clock_value_1) & (message.date_time_created <= P_clock_value_2) then call add_to_msg_struct (curr_msgsp, dc_count, i); end; end; /* do i = ... */ curr_msgs.count = dc_count; return; end date_current; next_token: proc (P_token_list) returns (char (*) var); dcl P_token_list char (*) var; dcl token char (length (P_token_list)) var; token = before (ltrim (P_token_list), " "); P_token_list = after (P_token_list, token); return (token); end next_token; add_to_msg_struct: proc (P_msg_structp, P_count, P_msg_num); dcl P_msg_structp ptr; dcl (P_count, P_msg_num) fixed bin; msg_structp = P_msg_structp; P_count = P_count + 1; msg_struct.numbers (P_count) = P_msg_num; return; end add_to_msg_struct; use_spec_msgs: proc (P_curr_msgsp, P_spec_msgsp); dcl (P_curr_msgsp, P_spec_msgsp) ptr; if P_curr_msgsp ^= null then free P_curr_msgsp -> curr_msgs; P_curr_msgsp = P_spec_msgsp; return; end use_spec_msgs; want_some: proc () returns (bit (1)); dcl yes_sw bit (1) aligned; call ioa_ ("^[^s^]^a", want_deleted_msgs, CURR_SET_MSG, CURR_DEL_SET_MSG); call ioa_ ("^(^-^d^/^)", curr_msgs.numbers); call xmail_get_str_$yes_no ((USE_SPEC_SET_PROMPT), yes_sw); return (yes_sw); end want_some; msg_deleted: proc (P_msg_num) returns (bit (1)); dcl P_msg_num fixed bin; if mailbox.messages (P_msg_num).message_ptr = null then do; call mail_system_$read_message (mailbox_ptr, P_msg_num, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", P_msg_num); end; message_ptr = mailbox.messages (P_msg_num).message_ptr; if message.marked_for_deletion then return ("1"b); else return ("0"b); end msg_deleted; msg_seen: proc (P_msg_num) returns (bit (1)); dcl P_msg_num fixed bin; if mailbox.messages (P_msg_num).message_ptr = null then do; call mail_system_$read_message (mailbox_ptr, P_msg_num, code); if code ^= 0 then call xmail_error_$no_code ( code, ME_CHAR, "l", "Unable to read message ^d. This is an interna; programming error.", P_msg_num); end; message_ptr = mailbox.messages (P_msg_num).message_ptr; if message.seen then return ("1"b); else return ("0"b); end msg_seen; set_counts: proc (P_curr_count, P_nonexist_count, P_code); dcl (P_curr_count, P_nonexist_count) fixed bin; dcl P_code fixed bin (35); P_code = 0; if P_curr_count = 0 /* None of the specified messages exist. */ then do; free curr_msgs; free nonexist_msgs; P_code = xmail_err_$no_msgs_exist; return; end; else curr_msgs.count = P_curr_count; if P_nonexist_count = 0 /* All exist. */ then free nonexist_msgs; else do; /* Some exist. */ nonexist_msgs.count = P_nonexist_count; if want_deleted_msgs then P_code = xmail_err_$some_del_msgs_exist; else P_code = xmail_err_$some_msgs_exist; end; return; end set_counts; alloc_msg_struct: proc (P_n_messages, P_msg_structp); dcl P_n_messages fixed bin; dcl P_msg_structp ptr; n_messages = P_n_messages; allocate msg_struct in (based_area); msg_struct.version = MSG_STRUCT_VERSION_1; P_msg_structp = msg_structp; return; end alloc_msg_struct; get_num: proc (P_str, P_code) returns (fixed bin); dcl P_code fixed bin (35); dcl P_str char (*); P_code = 0; if P_str = FIRST | P_str = F then do; if want_deleted_msgs then return (first_deleted ()); else return (first_existing ()); end; else if P_str = LAST | P_str = L then do; if want_deleted_msgs then return (last_deleted ()); else return (last_existing ()); end; else return (cv_dec_check_ (P_str, P_code)); end get_num; first_existing: proc () returns (fixed bin); dcl existing fixed bin; dcl i fixed bin; existing = 0; do i = 1 to mailbox.n_messages while (existing = 0); if ^msg_deleted (i) then existing = i; end; return (existing); end first_existing; first_deleted: proc () returns (fixed bin); dcl deleted fixed bin; dcl i fixed bin; deleted = 0; do i = 1 to mailbox.n_messages while (deleted = 0); if msg_deleted (i) then deleted = i; end; return (deleted); end first_deleted; last_existing: proc () returns (fixed bin); dcl existing fixed bin; dcl i fixed bin; existing = 0; do i = mailbox.n_messages to -1 by -1 while (existing = 0); if ^msg_deleted (i) then existing = i; end; return (existing); end last_existing; last_deleted: proc () returns (fixed bin); dcl deleted fixed bin; dcl i fixed bin; deleted = 0; do i = mailbox.n_messages to 1 by -1 while (deleted = 0); if msg_deleted (i) then deleted = i; end; return (deleted); end last_deleted; already_specified: proc (P_msg_num, P_curr_msgsp) returns (bit (1)); dcl i fixed bin; dcl P_curr_msgsp ptr; dcl P_msg_num fixed bin; do i = 1 to P_curr_msgsp -> curr_msgs.count; if P_msg_num = P_curr_msgsp -> curr_msgs.numbers (i) then return ("1"b); end; return ("0"b); end already_specified; end xmail_select_msgs_;  xmail_send_mail_print_msg_.pl1 09/02/88 0759.6r w 09/02/88 0746.2 47151 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Begin xmail_send_mail_print_msg_ */ /* Written by R. Ignagni July 1981 83-06-20 DJ Schimke: Modified to use new mail_system calls and version 2 mailboxes. Changed code to use xmail_data.mail_dir rather than determining this pathname for itself. */ xmail_send_mail_print_msg_: proc (); /* Proc called as consequence of user having selected the "Print" option in the Send Mail menu. The message is first placed in a temporary "screech" mailbox and then dprinted. It is initially placed in a mailbox so that the printing of all Exec Mail messages (from whatever menu) look exactly the same, i.e., the format of a msg in mailbox. */ /* Constant */ dcl CREATE_IF_NOT_FOUND bit (1) aligned static options (constant) init ("1"b); dcl DELETE_SEG_FORCE_CHASE bit (6) static options (constant) init ("100101"b); dcl NAME char (26) static options (constant) init ("xmail_send_mail_print_msg_"); dcl STOP char (1) static options (constant) init ("q"); dcl ERROR_MESSAGE char (65) static options (constant) init ("A program error has occurred. Cannot continue. Returning to menu."); /* Automatic */ dcl code fixed bin (35); dcl svmbx_dir char (168); dcl temporary_mailbox_name char (15); dcl 1 auto_open_options like open_options; dcl 1 auto_close_options like close_options; /* Entries */ dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl ioa_ entry () options (variable); dcl mail_system_$close_mailbox entry (ptr, ptr, fixed bin (35)); dcl mail_system_$open_mailbox entry (char (*), char (*), ptr, char (8), ptr, fixed bin (35)); dcl mail_system_$save_message entry (ptr, char (*), char (*), bit (1) aligned, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl xmail_error_$no_code entry () options (variable); dcl xmail_dprint_msgs_ entry (ptr, ptr); dcl xmail_select_msgs_$first entry (ptr, ptr, char (*)); /* Builtin */ dcl (addr, null) builtin; /* Error codes */ dcl mlsys_et_$savebox_created ext static fixed bin (35); /* Conditions */ dcl (quit, cleanup) condition; /* Include */ %page; %include xmail_send_mail; %page; %include xmail_data; %page; %include mlsys_mailbox; %page; %include mlsys_open_options; %page; %include mlsys_message; %page; %include xmail_curr_msg_info; %page; %include mlsys_close_options; %page; /* BEGIN */ temporary_mailbox_name = unique_chars_ ("0"b); svmbx_dir = ""; on condition (cleanup) call CLEAN_UP; on condition (quit) begin; dcl xmail_window_manager_$reconnect entry (); call xmail_window_manager_$reconnect (); call ioa_ ("""Print Sent Message"" terminated."); go to EXIT; end; /* See if message exits for "printing" */ if send_mail_info.msg_exists = "0"b | send_mail_info.emacs_seg_ptr = null () then do; call ioa_ ("There is no message to print."); go to EXIT; end; svmbx_dir = xmail_data.mail_dir; /* Save msg the temporary mbx so it can be dprinted */ call mail_system_$save_message (send_mail_info.new_msg_ptr, svmbx_dir, temporary_mailbox_name, CREATE_IF_NOT_FOUND, code); if code ^= 0 & code ^= mlsys_et_$savebox_created then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); /* Open mbx */ auto_open_options.version = OPEN_OPTIONS_VERSION_2; auto_open_options.message_selection_mode = ALL_MESSAGES; auto_open_options.sender_selection_mode = ALL_MESSAGES; auto_open_options.message_reading_level = READ_MESSAGES; mailbox_ptr = null (); call mail_system_$open_mailbox (svmbx_dir, temporary_mailbox_name || ".sv.mbx", addr (auto_open_options), MAILBOX_VERSION_2, mailbox_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); /* Determine the msg ptr so that the xmail_dprint_msgs_ proc can be called to actully request the dprint of the msg */ curr_msgsp = null (); call xmail_select_msgs_$first (mailbox_ptr, curr_msgsp, ""); call xmail_dprint_msgs_ (mailbox_ptr, curr_msgsp); /* Close mbx */ auto_close_options.version = CLOSE_OPTIONS_VERSION_2; auto_close_options.flags.perform_deletions = "0"b; auto_close_options.flags.report_deletion_errors = "0"b; auto_close_options.flags.mbz = "0"b; call mail_system_$close_mailbox (mailbox_ptr, addr (auto_close_options), code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); EXIT: call CLEAN_UP; return; CLEAN_UP: proc (); if svmbx_dir ^= "" then call delete_$path (svmbx_dir, temporary_mailbox_name || ".sv.mbx", DELETE_SEG_FORCE_CHASE, NAME, (0)); /* ignore code */ return; end CLEAN_UP; end xmail_send_mail_print_msg_;  xmail_send_msg_.pl1 09/02/88 0759.6r w 09/02/88 0745.9 138015 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-07,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): 85-04-01 JG Backs: Deleted the constant ASK because it was added to the include file xmail_responses.incl.pl1 and resulted in a compiler warning. 2) change(86-01-07,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Rearrange code to print the stmt that the message was sent before querying the user about whether he wants to save the message. 3) change(86-01-17,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Set the bit for cleanup_signalled on a quit condition (signalled by hitting break in response to *do you really want to quit*) so that the calling program will know that the message still exists. TR 20028. 4) change(86-01-28,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Add an on unit for the reissue_query condition inside the quit handler so that questions which the user types break in response to can be reissued. TRs 18711 18974. END HISTORY COMMENTS */ xmail_send_msg_: proc; /* BEGIN DESCRIPTION function: This proc delivers the message prepared by the user to the primary and (if any) the secondary recipients. It uses the mail_system_$deliver_message proc for this. Optionally, it saves the delivered message. It is called as a consequence of the user selecting the "Send" option in the Send Mail Menu. history: 81-07 Written by R. Ignagni, format: style1 83-07-21 DJ Schimke: Modified to use new mail_system calls and version 2 mailboxes. 83-10-06 DJ Schimke: Replaced calls to xmail_get_str_ with calls to xmail_get_str_$yes_no. 83-11-23 DJ Schimke: Added support for the new personalization option "Outgoing Savefile" which allows selection of where to file save messages. This also solves the discrepancy between setting "Save Outgoing messages" to "yes" and never having set "Save Outgoing messages". 83-12-07 DJ Schimke: Cleaned up the reporting of delivery results by calling mlsys_utils_$print_delivery_results_ and mlsys_utils_$print_address_field for displaying the failure/success of sending. This module still needs recovery code to allow the sender to correct the bad addresses and continue. 83-12-08 DJ Schimke: Added simple flag to prevent the call to mlsys_util_$free_delivery_results until the call to send the msg has been made. Otherwise, this cleanup will get errors referencing invalid pointers. 84-08-08 JG Backs: Modified for the addition of blind carbon copies. 84-11-07 JG Backs: Deleted the input parameter P_caller, which was not used anywhere in module. This also required modifying xmail_process_user_msgs_, which is the only other module that calls this module. Audit change. END DESCRIPTION */ /* CONSTANTS */ dcl ACKNOWLEDGE char (14) static options (constant) init ("acknowledge_yn"); dcl ALLOW_SELECTION bit (1) aligned static options (constant) init ("1"b); dcl CONTINUE char (1) static options (constant) init ("c"); dcl ERROR_MESSAGE char (67) static options (constant) init ("Sending of message not completed, due to an internal program error."); dcl ERRORS_ONLY bit (1) aligned static options (constant) init ("1"b); dcl LOG char (1) static options (constant) init ("l"); dcl MAILFILE_SUFFIX char (6) static options (constant) init ("sv.mbx"); dcl NAME char (15) static options (constant) init ("xmail_send_msg_"); dcl NO_SELECTION bit (1) aligned static options (constant) init ("0"b); dcl QUIT char (1) static options (constant) init ("q"); dcl SAVE_MAILBOX char (15) static options (constant) init ("save_mailfile"); dcl SAVE_MESSAGE char (15) static options (constant) init ("save_message_yn"); dcl USE_SCREEN_WIDTH fixed bin aligned static options (constant) init (-1); /* AUTOMATIC */ dcl acknowledge char (3) var; dcl code fixed bin (35); dcl code1 fixed bin (35); dcl delivery_results_need_cleanup bit (1) aligned; dcl opt fixed bin; dcl save_file char (32) var; dcl save_message char (3) var; dcl sci_ptr ptr; dcl send_area_ptr ptr; dcl yes_sw bit (1) aligned; dcl 1 auto_deliver_options like deliver_options; /* AREA */ dcl send_area area aligned based (send_area_ptr); /* CONDITIONS */ dcl (cleanup, quit, reissue_query) condition; /* EXTERNAL STATIC */ dcl iox_$user_output ptr static external; dcl mlsys_et_$no_a_permission ext static fixed bin (35); dcl error_table_$bad_segment fixed bin (35) ext static; /* ENTRIES */ dcl get_system_free_area_ entry () returns (ptr); dcl ioa_ entry () options (variable); dcl mail_system_$deliver_message entry (ptr, ptr, ptr, fixed bin (35)); dcl mlsys_utils_$free_delivery_results entry (ptr, fixed bin (35)); dcl mlsys_utils_$print_delivery_results entry (ptr, bit (1) aligned, ptr, fixed bin (35)); dcl mlsys_utils_$print_address_list_field entry (char (*) var, ptr, fixed bin, ptr, fixed bin (35)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl xmail_error_$code_first entry () options (variable); dcl xmail_error_$no_code entry () options (variable); dcl xmail_error_$no_print entry () options (variable); dcl xmail_file_msgs_$single_msg entry (ptr, char (32) var, bit (1) aligned); dcl xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); dcl xmail_send_msg_$ssu_exit entry (); dcl xmail_window_manager_$quit_handler entry () returns (bit (1) aligned); dcl xmail_window_manager_$reconnect entry (); dcl xmail_value_$get entry (char (*), char (*) var, fixed bin (35)); dcl xmail_value_$get_with_default entry (char (*), char (*) var, char (*) var, fixed bin (35)); /* BUILTINS */ dcl (addr, null) builtin; %page; /* INCLUDE FILES */ %include xmail_data; %page; %include mlsys_deliver_info; %page; %include xmail_responses; %page; %include xmail_send_mail; %page; %include window_dcls; /* BEGIN */ recipients_info_ptr, sci_ptr = null (); send_area_ptr = get_system_free_area_ (); delivery_results_need_cleanup = "0"b; xmail_data.flags.cleanup_signalled = "0"b; /* See if a message exists */ if send_mail_info.msg_exists = "0"b then do; call ioa_ ("There is no message to send."); goto EXIT; end; /* Set up conditions */ on condition (cleanup) call CLEAN_UP; on condition (quit) begin; on condition (reissue_query) begin; call window_$clear_window (iox_$user_output, (0)); goto RETRY (opt); end; xmail_data.cleanup_signalled = "1"b; if xmail_window_manager_$quit_handler () then do; call window_$clear_window (iox_$user_output, code); if code ^= 0 then do; call xmail_error_$no_print (code, NAME, CONTINUE, "Internal error trying to clear user_output"); call xmail_window_manager_$reconnect (); end; call ioa_ ("Sending message terminated."); call CLEAN_UP; goto EXIT; end; end; /* See if there is a "bcc" or "cc" list */ if send_mail_info.bcc_list_ptr ^= null () then if send_mail_info.cc_list_ptr ^= null () then recipients_info_n_lists = 3; else recipients_info_n_lists = 2; else if send_mail_info.cc_list_ptr ^= null () then recipients_info_n_lists = 2; else recipients_info_n_lists = 1; alloc recipients_info in (send_area) set (recipients_info_ptr); /* Add for bcc */ if send_mail_info.bcc_list_ptr ^= null () then if send_mail_info.cc_list_ptr ^= null () then do; recipients_info.lists (3).address_list_ptr = send_mail_info.bcc_list_ptr; recipients_info.lists (2).address_list_ptr = send_mail_info.cc_list_ptr; end; else recipients_info.lists (2).address_list_ptr = send_mail_info.bcc_list_ptr; else if send_mail_info.cc_list_ptr ^= null () then recipients_info.lists (2).address_list_ptr = send_mail_info.cc_list_ptr; recipients_info.lists (1).address_list_ptr = send_mail_info.to_list_ptr; recipients_info.lists (*).recipients_result_list_ptr = null (); recipients_info.version = RECIPIENTS_INFO_VERSION_2; recipients_info.area_ptr = get_system_free_area_ (); auto_deliver_options.version = DELIVER_OPTIONS_VERSION_2; auto_deliver_options.delivery_mode = ORDINARY_DELIVERY; auto_deliver_options.queueing_mode = ALWAYS_QUEUE_FOREIGN; auto_deliver_options.queued_notification_mode = NOTIFY_ON_ERROR; auto_deliver_options.flags.abort = "1"b; auto_deliver_options.flags.send_if_empty = "0"b; auto_deliver_options.flags.recipient_notification = "1"b; call xmail_value_$get_with_default (ACKNOWLEDGE, (NO), acknowledge, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG, "^/Unable to get a value for ""^a"" in the xmail value segment. Using the default value instead.", ACKNOWLEDGE); if acknowledge = NO then auto_deliver_options.flags.acknowledge = "0"b; else if acknowledge = ASK then do; RETRY (1): opt = 1; call xmail_get_str_$yes_no ("Do you want this message acknowledged? ", yes_sw); if yes_sw then auto_deliver_options.flags.acknowledge = "1"b; else auto_deliver_options.flags.acknowledge = "0"b; end; else if acknowledge = YES then auto_deliver_options.flags.acknowledge = "1"b; else do; call xmail_error_$code_first (error_table_$bad_segment, NAME, LOG, "^/An invalid value for ""^a"" was found in the xmail value segment. Using the default value instead.", ACKNOWLEDGE); auto_deliver_options.flags.acknowledge = "1"b; end; auto_deliver_options.flags.queue_mailing_lists = "0"b; auto_deliver_options.flags.mbz = "0"b; call mail_system_$deliver_message (send_mail_info.new_msg_ptr, recipients_info_ptr, addr (auto_deliver_options), code); delivery_results_need_cleanup = "1"b; if code ^= 0 then do; send_mail_info.msg_exists = "1"b; if code = mlsys_et_$no_a_permission then call xmail_error_$no_code (code, NAME, CONTINUE, "You do not have permission to send message to at least one of the recipients."); if recipients_info.n_failed_recipients > 0 then do; call ioa_ ("Message could not be sent."); call ssu_$standalone_invocation (sci_ptr, "", "", null (), xmail_send_msg_$ssu_exit, code1); if code1 = 0 then call mlsys_utils_$print_delivery_results (sci_ptr, ERRORS_ONLY, recipients_info_ptr, code1); else call xmail_error_$no_code (code1, NAME, LOG, "The reason cannot be printed due to an internal programming error"); call ssu_$destroy_invocation (sci_ptr); call xmail_error_$code_first (code, NAME, QUIT); end; call xmail_error_$code_first (code, NAME, QUIT, ERROR_MESSAGE); end; /* Report that the messge was sent. */ call ioa_ ("Message sent: "); call mlsys_utils_$print_address_list_field ("To", to_list_ptr, USE_SCREEN_WIDTH, null, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""To:"" recipient(s)."); if cc_list_ptr ^= null then do; call mlsys_utils_$print_address_list_field ("cc", cc_list_ptr, USE_SCREEN_WIDTH, null, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""cc:"" recipient(s)."); end; else call ioa_ ("cc: "); /* Add for bcc */ if bcc_list_ptr ^= null then do; call mlsys_utils_$print_address_list_field ("bcc", bcc_list_ptr, USE_SCREEN_WIDTH, null, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, CONTINUE, "Message sent to ""bcc:"" recipient(s)."); end; else call ioa_ ("bcc: "); /* Is this message to be saved? */ call xmail_value_$get (SAVE_MAILBOX, save_file, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG, "^/Unable to get a value for ""^a"" in the xmail value segment. Using the default value instead.", SAVE_MAILBOX); call xmail_value_$get (SAVE_MESSAGE, save_message, code); if code ^= 0 then call xmail_error_$code_first (code, NAME, LOG, "^/Unable to get a value for ""^a"" in the xmail value segment. Using the default value instead.", SAVE_MESSAGE); if save_message = YES then do; if save_file = ASK then call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, minus_suffix ((save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; else if save_message = ASK then do; RETRY (2): opt = 2; call xmail_get_str_$yes_no ("Do you wish to save a copy of this message? ", yes_sw); if yes_sw then do; if save_file = ASK then call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, "outgoing", ALLOW_SELECTION); else call xmail_file_msgs_$single_msg (send_mail_info.new_msg_ptr, minus_suffix ((save_file), (MAILFILE_SUFFIX)), NO_SELECTION); end; end; else if save_message ^= NO then call xmail_error_$code_first (error_table_$bad_segment, NAME, "q", "^/An invalid value for ""^a"" was found in the xmail value segment.", SAVE_MESSAGE); call CLEAN_UP; EXIT: return; /* ENTRY POINTS */ ssu_exit: entry; /* This entry doesn't do anything but it is called by ssu_$print_message */ /* which is called by mlsys_utils_$print_delivery_results. */ return; /* INTERNAL PROCEDURES */ minus_suffix: proc (name, suffix) returns (char (*) var); /* PARAMETERS */ dcl name char (*); dcl suffix char (*); /* AUTOMATIC */ dcl reverse_name char (length (name)) var; dcl reverse_suffix char (length (suffix)) var; /* BUILTINS */ dcl (after, index, length, reverse, rtrim) builtin; reverse_name = reverse (rtrim (name)); reverse_suffix = reverse (rtrim (suffix)); if index (reverse_name, reverse_suffix || ".") ^= 1 then return (name); else return (reverse (after (reverse_name, reverse_suffix || "."))); end minus_suffix; CLEAN_UP: proc (); if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); if recipients_info_ptr ^= null () then do; if delivery_results_need_cleanup then do; call mlsys_utils_$free_delivery_results (recipients_info_ptr, code1); if code1 ^= 0 then call xmail_error_$no_print (code1, NAME, CONTINUE, "While cleaning up delivery results."); end; free recipients_info in (send_area); recipients_info_ptr = null (); end; return; end CLEAN_UP; end xmail_send_msg_;  xmail_send_stored_msg_.pl1 09/02/88 0759.6r w 09/02/88 0745.8 105678 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-12-10,Blair), approve(87-12-10,MCR7818), audit(87-12-23,LJAdams), install(88-01-12,MR12.2-1013): Add capability to update a deferred message to include a reply-to field. END HISTORY COMMENTS */ xmail_send_stored_msg_: proc (); /* BEGIN DESCRIPTION History: Author unknown 83-07-21 DJ Schimke: Declared addr, codeptr, divide, null, and rtrim builtins. Removed unreferenced char_count, emacs_data_$status_code, program_interrupt. 83-10-15 DJ Schimke: Removed useless cleanup handler and performed other general code restructuring suggested by audit. 83-10-26 DJ Schimke: Changed call to xmail_window_manager_$reconnect to a call to xmail_window_manager_$quit_handler so the quit condition handler can special-case the reconnect condition which should NOT interrupt processing after the quit. phx 13227 This entry also prompts when not at a reconnect condition so that unintentionally hitting the BREAK won't throw away any pending work. phx 13018 83-11-01 DJ Schimke: Changed calling sequence of xmail_select_file_. 84-09-24 JG Backs: Added code before and after the call to emacs_ to test if menus should be removed before editing (personalization option Remove Menus While Editing). If option is in effect, calls to new entrypoints, $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also added test in quit handler to make sure restore menus is done if quit in editor. 84-11-08 JG Backs: Changed the call and declaration statement of xmail_process_user_msg_ to eliminate the parameter which was not needed or used, and was eliminated from that module. Audit change. END DESCRIPTION */ /* AUTOMATIC */ dcl bit_count fixed bin (24); dcl buffer_used fixed bin; dcl code fixed bin (35); dcl flavor char (32); dcl format_reply char (32); dcl format_reply_length fixed bin; dcl length_first_part fixed bin; dcl message_num fixed bin; dcl no_chars fixed bin (21); dcl restore_menu_needed bit (1) aligned; /* if remove menu */ dcl status fixed bin (35); dcl store_dir char (168); dcl store_file char (32) var; dcl stored_msg_ptr ptr; dcl type fixed bin (2); dcl unused_bit bit (1) aligned; dcl unused_bit2 bit (1) aligned; dcl user_name char (22); dcl 1 auto_parse_text_options like parse_text_options; /* INTERNAL STATIC */ dcl ext_dir char (168) int static; dcl ext_file char (32) int static; dcl ext_pname char (168) int static; dcl ext_ptr ptr init (null) int static; /* CONSTANTS */ dcl ALLOW_OLD bit (1) aligned options (constant) init ("1"b) int static; dcl BITS_PER_BYTE fixed bin (4) aligned options (constant) init (9) int static; dcl DONT_ALLOW_NEW bit (1) aligned options (constant) init ("0"b) int static; dcl EMACS_EXT char (21) options (constant) init ("xmail_emacs_ext_main_") int static; dcl ENTRY_NAME entry variable init (xmail_send_stored_msg_); dcl ERROR_MESSAGE char (66) static options (constant) init ("Sorry, due to an internal error the stored message cannot be sent."); dcl LOG char (1) static options (constant) init ("l"); dcl MAKE_SEG_RW fixed bin (5) static options (constant) init (01010b); dcl NAME char (22) static options (constant) init ("xmail_send_stored_msg_"); dcl NL char (1) aligned static options (constant) init (" "); dcl STOP char (1) static options (constant) init ("q"); dcl TERM_FILE_BC bit (2) static options (constant) init ("01"b); dcl WHITE_SPACE_COMMA char (6) aligned static options (constant) init (" ,"); /* HT VT NL comma */ /* EXTERNAL STATIC */ dcl iox_$user_output ptr external static; dcl (error_table_$namedup, error_table_$segknown) fixed bin (35) ext; /* ENTRIES */ dcl emacs_ entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl get_pdir_ entry () returns (char (168)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl mlsys_utils_$parse_address_list_text entry options(variable); dcl mlsys_utils_$format_text_field entry options(variable); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl user_info_ entry (char(*)); dcl xmail_error_$no_code entry options (variable); dcl xmail_process_user_msg_ entry (); /* no parameter */ dcl xmail_redisplay_$menu entry (); dcl xmail_select_file_$caller_msg entry (char (*), char (*), char (*), bit (1) aligned, bit (1) aligned, char (168), char (32) var, char (*), bit (1) aligned, bit (1) aligned, fixed bin (35)); dcl xmail_window_manager_$quit_handler entry () returns (bit (1) aligned); dcl xmail_window_manager_$reconnect entry (); dcl xmail_window_manager_$restore_menu entry (); dcl xmail_window_manager_$suppress_menu entry (); /* CONDITIONS */ dcl quit condition; /* BASED */ dcl stored_string char (no_chars) based (stored_msg_ptr); dcl emacs_seg_string char (no_chars) based (send_mail_info.emacs_seg_ptr); /* BUILTINS */ dcl (addr, after, before, codeptr, divide, index, length, null, rtrim, substr) builtin; /* INCLUDE FILES */ %include xmail_send_mail; %page; %include xmail_data; %page; %include mlsys_parse_txt_options; %page; %include window_dcls; %page; %include mlsys_address_list; %page; %include mlsys_field_names; /* BEGIN */ restore_menu_needed = "0"b; on condition (quit) begin; if xmail_window_manager_$quit_handler () then do; if restore_menu_needed then do; call xmail_window_manager_$restore_menu; call xmail_redisplay_$menu; end; call window_$clear_window (iox_$user_output, (0)); /* ignore code */ call ioa_ ("Sending ""deferred message"" terminated."); go to EXIT; end; end; call xmail_select_file_$caller_msg ("deferred message", "defer", "", ALLOW_OLD, DONT_ALLOW_NEW, store_dir, store_file, "Enter name of ""deferred message"" (or ?? for list)", unused_bit, unused_bit2, code); if code ^= 0 then go to EXIT; call hcs_$make_seg (store_dir, rtrim (store_file) || ".defer", "", MAKE_SEG_RW, stored_msg_ptr, code); call hcs_$status_mins (stored_msg_ptr, type, bit_count, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); /* Set up to add a Reply_To field if none exists */ auto_parse_text_options.version = PARSE_TEXT_OPTIONS_VERSION_1; auto_parse_text_options.area_ptr = null(); auto_parse_text_options.flags.list_errors = "0"b; auto_parse_text_options.flags.validate_addresses = "0"b; auto_parse_text_options.flags.include_invalid_addresses = "0"b; auto_parse_text_options.flags.mbz = "0"b; call user_info_ (user_name); /* we might need this */ /* Get number of chars in seg */ if bit_count = 0 then do; call ioa_ ("The specified ""deferred message"" is empty."); go to EXIT; end; no_chars = divide (bit_count, 9, 17, 0); reply_to_list_ptr = null; if index(before(stored_string,NL || "To:"), "Reply-To:") > 0 then do; call mlsys_utils_$parse_address_list_text (rtrim (after (before (stored_string, "To:"), "Reply-To:"), WHITE_SPACE_COMMA), addr (auto_parse_text_options), ADDRESS_LIST_VERSION_2, reply_to_list_ptr, parse_text_error_list_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); end; else do; format_reply = ""; format_reply_length = length ("Reply-To: ") + length(user_name); call mlsys_utils_$format_text_field (REPLY_TO_FIELDNAME, rtrim(user_name), ("0"b), format_reply_length, addr(format_reply), format_reply_length, buffer_used, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, LOG, ERROR_MESSAGE, message_num); no_chars = format_reply_length + length(NL) + no_chars; bit_count = no_chars * BITS_PER_BYTE; length_first_part = index(stored_string,NL); stored_string = substr(stored_string,1,length_first_part) || rtrim(format_reply) || NL || substr(stored_string,length_first_part+1, no_chars - (length_first_part + length(NL) + format_reply_length)); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); end; call hcs_$make_seg ("", xmail_data.actee.person || "_sm", "", MAKE_SEG_RW, send_mail_info.emacs_seg_ptr, code); if code ^= 0 & code ^= error_table_$namedup & code ^= error_table_$segknown then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); call terminate_file_ (send_mail_info.emacs_seg_ptr, bit_count, TERM_FILE_BC, code); emacs_seg_string = stored_string; if ext_ptr = null () then do; call hcs_$make_ptr (codeptr (ENTRY_NAME), EMACS_EXT, "", ext_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); ext_pname = rtrim (ext_dir) || ">" || EMACS_EXT; end; flavor = "edit"; call ioa_ ("...Please wait for editor..."); /* Check personalization option to remove and restore menus while editing */ if xmail_data.remove_menus then do; call xmail_window_manager_$suppress_menu (); restore_menu_needed = "1"b; end; call emacs_ (iox_$user_output, rtrim (get_pdir_ ()) || ">" || rtrim (actee.person) || "_sm", ext_pname, addr (flavor), status); if restore_menu_needed then do; call xmail_window_manager_$restore_menu (); call xmail_redisplay_$menu; restore_menu_needed = "0"b; end; if status = 1 then do; call hcs_$status_mins (send_mail_info.emacs_seg_ptr, 1, bit_count, code); if code ^= 0 then call xmail_error_$no_code (code, NAME, STOP, "^a", ERROR_MESSAGE); no_chars = divide (bit_count, 9, 17, 0); stored_string = emacs_seg_string; call hcs_$set_bc_seg (stored_msg_ptr, bit_count, code); call ioa_ ("Deferred message ""^a"" saved.", store_file); go to EXIT; end; if status ^= 0 then do; call xmail_window_manager_$reconnect (); call ioa_ ("Sending ""deferred message"" terminated."); go to EXIT; end; else call xmail_process_user_msg_ (); /* no parameter */ EXIT: return; end xmail_send_stored_msg_;  xmail_sw_.pl1 09/02/88 0759.6r w 09/02/88 0745.6 70515 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-02-27,Blair), approve(86-02-27,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): 85-03-08 JGBacks: Deleted two unused entrypoints $update_actee and $update_date, plus variables, external entries, and the clock builtin used by them. Format statement was also removed because it was wrong. END HISTORY COMMENTS */ xmail_sw_: initialize: proc (); /* BEGIN DESCRIPTION history: Written before June 81 by S. Krupp Modified June 81 by P. Kyzivat during extensive changes to xmail 83-07-27 Dave Schimke: Delete dcls for unreferenced items: code, convert_date_to_binary_, timer_manager_$alarm_call, and timer_manager_$reset_alarm_call. 83-10-15 DJ Schimke: Cleanup the code to satisfy audit. END DESCRIPTION */ /* ENTRIES */ dcl window_display_ entry (ptr, (*) char (*), fixed bin (35)); dcl xmail_error_$no_print entry () options (variable); /* BASED */ dcl display_window (xmail_windows.status.height) char (window_image_width) based (window_image_ptr); dcl window_image (3) char (window_image_width) based (window_image_ptr); /* BUILTINS */ dcl (addr, copy, divide, length, ltrim, min, string, rtrim) builtin; /* CONSTANTS */ dcl LOG char (1) int static options (constant) init ("l"); dcl NAME char (9) int static options (constant) init ("xmail_sw_"); /* INTERNAL STATIC */ dcl file_field_len fixed bin int static; dcl file_info_field_len fixed bin int static; dcl pos_field_len fixed bin int static; dcl usage_field_len fixed bin int static; dcl window_image_ptr ptr int static; dcl window_image_width fixed bin int static; dcl static_window_image (3) char (132) unal static; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is called only once per xmail invocation to initialize the status window. */ /* It sets all the internal static variables used in the other entry points. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ static_window_image (*) = ""; window_image_ptr = addr (static_window_image); window_image_width = min (length (static_window_image (1)), xmail_windows.status.width); string (window_image) = ""; file_field_len, file_info_field_len = 0; usage_field_len = window_image_width - (file_field_len + file_info_field_len); pos_field_len = window_image_width; return; update_file: entry (str); dcl str char (*); if str ^= "" then file_field_len = 20; call UPDATE (1, 1, file_field_len, str); /* file name goes on line 1, col 1 */ if str = "" then file_field_len = 0; return; update_file_info: entry (str); if str ^= "" then file_info_field_len = 20; begin; dcl field char (file_info_field_len); dcl trimmed_value char (length (str)) var; dcl trimmed_len fixed bin; dcl starting_col fixed bin; starting_col = window_image_width - file_info_field_len + 1; trimmed_value = ltrim (rtrim (str)); trimmed_len = length (trimmed_value); if trimmed_len < file_info_field_len then do; call RIGHT_JUSTIFY ((trimmed_value), field); call UPDATE (1, starting_col, file_info_field_len, field); end; else call UPDATE (1, starting_col, file_info_field_len, str); if str = "" then file_info_field_len = 0; return; end; /* begin */ update_position: entry (str); begin; dcl field char (pos_field_len); dcl trimmed_value char (length (str)) var; dcl trimmed_len fixed bin; trimmed_value = ltrim (rtrim (str)); trimmed_len = length (trimmed_value); if trimmed_len < pos_field_len then do; call CENTER ((trimmed_value), field); call UPDATE (2, 1, pos_field_len, field); end; else call UPDATE (2, 1, pos_field_len, str); return; end; /* begin */ update_usage: entry (str); dcl used_cols fixed bin; dcl rused_cols fixed bin; if file_field_len ^= 0 & file_info_field_len ^= 0 then used_cols = file_field_len + file_info_field_len; else used_cols = 2 * (file_field_len + file_info_field_len); rused_cols = divide (used_cols, 2, 17, 0); usage_field_len = window_image_width - used_cols; begin; dcl field char (usage_field_len); dcl trimmed_value char (length (str)) var; dcl trimmed_len fixed bin; dcl starting_col fixed bin; starting_col = window_image_width - (rused_cols + usage_field_len) + 1; trimmed_value = ltrim (rtrim (str)); trimmed_len = length (trimmed_value); if trimmed_len < usage_field_len then do; call CENTER ((trimmed_value), field); call UPDATE (1, starting_col, usage_field_len, field); end; else call UPDATE (1, starting_col, usage_field_len, str); return; end; /* begin */ redisplay: entry (); dcl code fixed bin (35); call window_display_ (xmail_windows.status.iocb, display_window, code); if code ^= 0 then call xmail_error_$no_print (code, NAME, LOG); return; CENTER: proc (P_str, P_field); dcl (P_str, P_field) char (*); dcl (field_len, str_len, n_pad, l_pad) fixed bin; field_len = length (P_field); str_len = length (P_str); n_pad = field_len - str_len; l_pad = divide (n_pad, 2, 17, 0); P_field = copy (" ", l_pad) || P_str; end CENTER; RIGHT_JUSTIFY: proc (P_str, P_field); dcl (P_str, P_field) char (*); dcl (field_len, str_len, n_pad) fixed bin; field_len = length (P_field); str_len = length (P_str); n_pad = field_len - str_len; P_field = copy (" ", n_pad) || P_str; end RIGHT_JUSTIFY; UPDATE: proc (line, col, len, new_value); dcl (line, col, len) fixed bin, new_value char (*); dcl short_new_value defined (new_value) char (len), trunc_new_value defined (new_value) char (len - length (TRUNCATION_STRING)); dcl TRUNCATION_STRING init (" ...") char (4) static options (constant); dcl (length, rtrim) builtin; if len >= length (new_value) then call RAW_UPDATE (line, col, len, new_value); else if len <= length (TRUNCATION_STRING) | len >= length (rtrim (new_value)) then call RAW_UPDATE (line, col, len, short_new_value); else do; call RAW_UPDATE (line, col, length (trunc_new_value), trunc_new_value); call RAW_UPDATE (line, col + length (trunc_new_value), length (TRUNCATION_STRING), TRUNCATION_STRING); end; end UPDATE; RAW_UPDATE: proc (line, col, len, new_value); dcl (line, col, len) fixed bin, new_value char (*); dcl field_p ptr, field_l fixed bin, field char (field_l) based (field_p); dcl (addr, char, substr) builtin; field_p = addr (substr (window_image (line), col)); field_l = len; if char (new_value, len) ^= field then field = new_value; end RAW_UPDATE; %include xmail_data; %page; %include xmail_windows; %page; %include window_dcls; end xmail_sw_;  xmail_undelete_msgs_.pl1 09/02/88 0759.6r w 09/02/88 0745.5 32256 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-02-26,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): On a cleanup exit ( user hits break when in Multics mode) we come here to undelete any messages marked for deletion, but we don't want to put out the message to the user. END HISTORY COMMENTS */ xmail_undelete_msgs_: proc (P_mailbox_ptr, P_curr_msgsp, P_pos_line, P_flavor); /* Author unknown 83-07-27 DJ Schimke: Modified to use new mail_system calls and version 2 mailboxes. */ /* Parameter */ dcl P_mailbox_ptr ptr; dcl P_curr_msgsp ptr; dcl P_pos_line char (*); dcl P_flavor char (*); /* Automatic */ dcl add_more_msg bit (1) aligned; dcl code fixed bin (35); dcl deleted_msgsp ptr; dcl i fixed bin; dcl message_num fixed bin; dcl message_ptr ptr; /* Builtin */ dcl (length, maxlength, null, rtrim) builtin; /* Entries */ dcl ioa_ entry () options (variable); dcl mail_system_$read_message entry (ptr, fixed bin, fixed bin (35)); dcl mail_system_$unmark_message_for_deletion entry (ptr, fixed bin (35)); dcl xmail_error_$no_code entry () options (variable); dcl xmail_select_msgs_$deleted entry (ptr, ptr, char (*)); dcl xmail_select_msgs_$replace_curr entry (ptr, ptr, char (*)); /* Constant */ dcl ME_CHAR char (20) init ("xmail_undelete_msgs_") int static options (constant); dcl MORE_MSG char (9) init (" MORE ...") int static options (constant); mailbox_ptr = P_mailbox_ptr; call xmail_select_msgs_$deleted (mailbox_ptr, deleted_msgsp, P_flavor); if deleted_msgsp = null then goto EXIT; do i = 1 to deleted_msgsp -> curr_msgs.count; message_num = deleted_msgsp -> curr_msgs.numbers (i); if mailbox.messages (message_num).message_ptr = null then do; call mail_system_$read_message (mailbox_ptr, message_num, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to read message ^d. This is an internal programming error.", message_num); end; message_ptr = mailbox.messages (message_num).message_ptr; call mail_system_$unmark_message_for_deletion (message_ptr, code); if code ^= 0 then call xmail_error_$no_code (code, ME_CHAR, "l", "Unable to retrieve message ^d. This is an internal programming error.", message_num); end; call xmail_select_msgs_$replace_curr (P_curr_msgsp, deleted_msgsp, P_pos_line); if length (rtrim (P_pos_line)) > maxlength (P_pos_line) - length (MORE_MSG) then add_more_msg = "1"b; else add_more_msg = "0"b; if ^xmail_data.cleanup_signalled then call ioa_ ("Message^[s^;^] ^a ^[^a^] retrieved.", (deleted_msgsp -> curr_msgs.count > 1), rtrim (P_pos_line), add_more_msg, MORE_MSG); EXIT: return; %page; %include xmail_curr_msg_info; %page; %include mlsys_mailbox; %page; %include xmail_prompts; %page; %include xmail_data; end xmail_undelete_msgs_;  xmail_update_mlist_.pl1 09/02/88 0759.6r w 09/02/88 0745.4 44343 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-04-16,Blair), approve(86-04-16,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Remove unreferenced constants. END HISTORY COMMENTS */ xmail_update_mlist_: proc (P_dir, P_file); /* BEGIN DESCRIPTION History: Author unknown 83-10-26 DJ Schimke: Added quit condition handler with a call to xmail_window_manager_$quit_handler to special-case the reconnect condition which should NOT interrupt processing after the quit. phx 13227 This entry also prompts when not at a reconnect condition so that unintentionally hitting the BREAK won't throw away any pending work. phx 13018 84-09-24 JG Backs: Added code before and after the call to emacs_ to test if menus should be removed before editing (personalization option Remove Menus While Editing). If option is in effect, calls to new entrypoints, $suppress_menu and $restore_menu in xmail_window_manager_ are made. Also added test in quit handler to make sure restore menus is done if quit in editor. END DESCRIPTION */ /* PARAMETERS */ dcl (P_dir, P_file) char (*); /* AUTOMATIC */ dcl code fixed bin (35); dcl restore_menu_needed bit (1) aligned; /* if remove menu */ dcl seg_pname char (168); /* BUILTINS */ dcl (codeptr, null, rtrim) builtin; /* ENTRIES */ dcl com_err_$suppress_name entry () options (variable); dcl emacs_ entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl xmail_redisplay_$menu entry (); dcl xmail_window_manager_$quit_handler entry () returns (bit (1) aligned); dcl xmail_window_manager_$reconnect entry (); dcl xmail_window_manager_$restore_menu entry (); dcl xmail_window_manager_$suppress_menu entry (); /* INTERNAL STATIC */ dcl ext_dir char (168) int static; dcl ext_file char (32) int static; dcl ext_pname char (168) int static; dcl ext_ptr ptr init (null) int static; /* EXTERNAL STATIC */ dcl iox_$user_io ptr ext static; dcl xmail_err_$int_prog_err fixed bin (35) ext static; /* CONSTANTS */ dcl EXTENSION_ENAME char (22) init ("xmail_emacs_ext_mlist_") int static options (constant); dcl ME_CHAR char (19) init ("xmail_update_mlist_") int static options (constant); dcl ME_ENTRY entry variable init (xmail_update_mlist_); /* CONDITIONS */ dcl (quit) condition; /* INCLUDE FILES */ %include xmail_data; /* BEGIN */ restore_menu_needed = "0"b; if ext_ptr = null then do; call hcs_$make_ptr (codeptr (ME_ENTRY), EXTENSION_ENAME, "", ext_ptr, code); if code ^= 0 then call update_mlist_err (xmail_err_$int_prog_err, "Trying to locate extension."); call hcs_$fs_get_path_name (ext_ptr, ext_dir, (0), ext_file, code); if code ^= 0 then call update_mlist_err (xmail_err_$int_prog_err, "Trying to get extension pathname"); ext_pname = rtrim (ext_dir) || ">" || rtrim (EXTENSION_ENAME); end; on condition (quit) begin; if xmail_window_manager_$quit_handler () then do; if restore_menu_needed then do; call xmail_window_manager_$restore_menu; call xmail_redisplay_$menu; end; go to EXIT; end; end; seg_pname = rtrim (P_dir) || ">" || rtrim (P_file); call ioa_ ("... Please wait for editor ..."); /* Check personalization option to remove and restore menus while editing */ if xmail_data.remove_menus then do; call xmail_window_manager_$suppress_menu (); restore_menu_needed = "1"b; end; call emacs_ (iox_$user_io, seg_pname, ext_pname, null, code); if restore_menu_needed then do; call xmail_window_manager_$restore_menu (); call xmail_redisplay_$menu; restore_menu_needed = "0"b; end; if code ^= 0 then call xmail_window_manager_$reconnect (); EXIT: return; %page; /* INTERNAL PROCEDURES */ update_mlist_err: proc (P_code, P_str); dcl P_code fixed bin (35); dcl P_str char (*); call com_err_$suppress_name (P_code, ME_CHAR); go to EXIT; end update_mlist_err; end xmail_update_mlist_;  xmail_validate_.pl1 09/02/88 0759.6rew 09/02/88 0736.1 55008 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-06-29,Blair), approve(88-07-27,MCR7931), audit(88-08-30,RBarstad), install(88-09-02,MR12.2-1098): Call mail_system_$create_mailing_list_address to generate the address rather than generating it ourselves with the "{list ...}" construct. This will allow names with embedded blanks. END HISTORY COMMENTS */ xmail_validate_: proc (); /* Author unknown 83-07-27 DJ Schimke: Modified to use new mail_system_ interfaces and version 2 mailboxes. 83-09-14 DJ Schimke: Modified the call to hcs_$status_minf so a link to a mailing list is considered a valid mailing list. TR12078 */ /* Parameter */ dcl P_addr_str char (*); dcl P_code fixed bin (35); dcl P_curr_msgsp ptr; dcl P_mailbox_ptr ptr; /* Automatic */ dcl address_ptr ptr; dcl addr_str char (200); dcl bit_count fixed bin (24); dcl code fixed bin (35); dcl mailing_list bit (1) aligned; dcl mlist_name char (32); dcl type fixed bin (2); /* Entries */ dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl mlsys_utils_$parse_address_text entry (char (*), ptr, fixed bin (35)); dcl mail_system_$create_mailing_list_address entry (char (*), char (*), char (*), char (*) varying, char (*) varying, ptr, fixed bin (35)); dcl mail_system_$free_address entry (ptr, fixed bin (35)); dcl mail_system_$validate_address entry entry (ptr, bit (1) aligned, fixed bin (35)); /* Constant */ dcl CHASE fixed bin (1) init (1) int static options (constant); dcl MLIST_SUFFIX char (4) init (".mls") int static options (constant); dcl SEG fixed bin (2) init (1) int static options (constant); dcl VALIDATE_LIST bit (1) aligned init ("1"b) int static options (constant); /* External Static */ dcl (error_table_$badcall, error_table_$unimplemented_version, error_table_$noaccess, mlsys_et_$message_queued, mlsys_et_$no_mailbox, xmail_err_$bad_mailing_list, xmail_err_$mailing_list) fixed bin (35) ext; /* Builtin */ dcl (ltrim, null, rtrim) builtin; mbx: entry (P_mailbox_ptr, P_code); P_code = 0; if P_mailbox_ptr = null then do; P_code = error_table_$badcall; return; end; mailbox_ptr = P_mailbox_ptr; if mailbox.version ^= MAILBOX_VERSION_2 then do; P_code = error_table_$unimplemented_version; return; end; return; /* mbx entry */ curr_msgs: entry (P_curr_msgsp, P_code); P_code = 0; if P_curr_msgsp = null then do; P_code = error_table_$badcall; return; end; curr_msgsp = P_curr_msgsp; if curr_msgs.version ^= MSG_STRUCT_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; return; /* curr_msgs entry */ addr: entry (P_addr_str, P_code); /* Important codes returned by this entry: 0 -- P_addr_str is an address with good syntax and is deliverable xmail_err_$mailing_list -- P_addr_str specifies a valid mailing list mlsys_et_$invalid_address_syntax -- P_addr_str is an address with invalid syntax mlsys_et_$no_mailbox -- P_addr_str is an address with good syntax, but is undeliverable mlsys_et_$no_a_permission -- P_addr_str is an address with good syntax but, is undeliverable mlsys_et_$mte_not_found -- P_addr_str is good syntax for a mail_table address, but no such mail_table entry exists */ /* Is it a mailing list name? */ mlist_name = ltrim (rtrim (P_addr_str)) || MLIST_SUFFIX; call hcs_$status_minf ((xmail_data.mail_dir), mlist_name, CHASE, type, bit_count, code); if code = 0 & type = SEG then do; mailing_list = "1"b; call mail_system_$create_mailing_list_address ((xmail_data.mail_dir), mlist_name, "", "", "", address_ptr, code); if code ^= 0 then do; P_code = code; goto EXIT; end; end; else do; mailing_list = "0"b; /* if code ^= 0 ignore and assume it's not a mailing_list */ addr_str = P_addr_str; call mlsys_utils_$parse_address_text (addr_str, address_ptr, code); if code ^= 0 then do; P_code = code; goto EXIT; end; end; /* If the syntax is ok, is there a corresponding mailbox? */ /* For mailing_lists, are all addresses valid? */ call mail_system_$validate_address (address_ptr, VALIDATE_LIST, code); if code = 0 | code = mlsys_et_$message_queued then P_code = 0; else if code = error_table_$noaccess then P_code = mlsys_et_$no_mailbox; else P_code = code; EXIT: call mail_system_$free_address (address_ptr, (0));/* ignore error */ if mailing_list then do; if P_code = 0 then P_code = xmail_err_$mailing_list; else P_code = xmail_err_$bad_mailing_list; end; return; /* addr entry */ %page; %include mlsys_mailbox; %page; %include xmail_curr_msg_info; %page; %include xmail_data; end xmail_validate_;  xmail_value_.pl1 09/02/88 0759.6r w 09/02/88 0745.2 115551 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-02-26,Blair), approve(86-02-26,MCR7358), audit(86-04-18,RBarstad), install(86-05-28,MR12.0-1062): Add new internal procedures to get the value segment ptr, validate the value returned by value_$get, and determine the default value for a particular name. There is a table of names of the values used by xmail and validate_name_and_index returns the index to tables of validation routines and default values. There is also a new entry point - get_no_validate. 2) change(86-07-15,Blair), approve(86-07-15,MCR7447), audit(86-07-16,LJAdams), install(86-07-21,MR12.0-1100): Initiate the data_seg for RW when getting the pointer to it so as to avoid problems with differing ring-brackets. 3) change(87-01-21,Blair), approve(87-02-05,MCR7618), audit(87-04-10,RBarstad), install(87-04-26,MR12.1-1025): Make entries in the default_value array and test_value array for the new value seg entry msgs_as_mail_yn. END HISTORY COMMENTS */ /* xmail_value_ This program provides an interface to the xmail value segment. Entries are provided to manipulate named values. The actual management of the segment is performed via the value_$... utility subroutines for dealing with value segments. The entries provided here provide primarily a subset of the capabilities provided by value_, the major difference being that the specification of the value segment itself is absent. The other major change is that arbitrary datatypes are not allowed. To ease the implementation, names are always char (*) and values are always char (*) varying. Additional functionality has been added in the form of a new entrypoint, get_with_default, which automatically returns a specified default value when the name is not defined. The following parameter names are common to the various entries: name: the name of the value to be referenced in_value: a value supplied by the caller out_value: a value returned to the caller test_value: a value supplied by the caller for test purposes code a system status code as returned by value_ ************************************************************** The following entrypoints are defined: defined (name, code) returns (bit (1)) delete (name, code) get (name, out_value, code) set (name, in_value, out_value, code) test_and_set (name, in_value, test_value, code) get_with_default (name, in_value, out_value, code) In set, out_value is the old value before it was changed. In get_with_default, in_value is the default, which is returned in out_value if no value is defined. */ /* Written 6/29/81 by Paul Kyzivat */ /* format: style1 */ %page; xmail_value_: proc; dcl name char (*) parameter, in_value char (*) varying parameter, out_value char (*) varying parameter, test_value char (*) varying parameter, code fixed bin (35); dcl index fixed bin; dcl (fixed, length, null, rtrim, search, verify) builtin; dcl value_seg_ptr ptr; dcl PERMANENT init ("01"b) bit (36) aligned static options (constant); dcl error_table_$oldnamerr fixed bin (35) ext static; dcl value_$defined entry (ptr, bit (36) aligned, char (*), fixed bin (35)) returns (bit (1) aligned), ( value_$delete, value_$get, value_$set, value_$test_and_set ) entry options (variable); dcl xmail_rebuild_value_seg_ entry (ptr, fixed bin (35)); %page; defined: entry (name, code) returns (bit (1)); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); return (value_$defined (value_seg_ptr , PERMANENT, name, code)); delete: entry (name, code); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); call value_$delete (value_seg_ptr, PERMANENT, name, code); return; get: entry (name, out_value, code); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); if value_seg_ptr ^= null then call value_$get (value_seg_ptr, PERMANENT, name, out_value, code); if code = error_table_$oldnamerr & (index > 14 & index < 21) then; else if code ^= 0 | value_seg_ptr = null then do; call xmail_rebuild_value_seg_ (value_seg_ptr, code); call get_default_value (index, out_value); end; else do; call validate_returned_value (index, out_value, code); if code ^= 0 then do; call xmail_rebuild_value_seg_ (value_seg_ptr, code); call get_default_value (index, out_value); end; end; return; get_no_validate: entry (name, out_value, code); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); if value_seg_ptr ^= null then call value_$get (value_seg_ptr, PERMANENT, name, out_value, code); if code = error_table_$oldnamerr then; else if code ^= 0 | value_seg_ptr = null then do; call xmail_rebuild_value_seg_ (value_seg_ptr, code); call get_default_value (index, out_value); end; return; set: entry (name, in_value, out_value, code); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); if value_seg_ptr = null then call xmail_rebuild_value_seg_ (value_seg_ptr, code); call value_$set (value_seg_ptr, PERMANENT, name, in_value, out_value, code); if code ^= 0 then do; call xmail_rebuild_value_seg_ (value_seg_ptr, code); call get_default_value (index, out_value); end; return; test_and_set: entry (name, in_value, test_value, code); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); call value_$test_and_set (value_seg_ptr, PERMANENT, name, in_value, out_value, code); if code ^= 0 then do; call xmail_rebuild_value_seg_ (value_seg_ptr, code); call get_default_value (index, out_value); end; return; get_with_default: entry (name, in_value, out_value, code); call validate_value_seg (value_seg_ptr); call validate_name_and_index (name, index); if value_seg_ptr ^= null then call value_$get (value_seg_ptr, PERMANENT, name, out_value, code); if (code = error_table_$oldnamerr) then do; out_value = in_value; code = 0; end; else if code ^= 0 then do; call xmail_rebuild_value_seg_ (value_seg_ptr, code); call get_default_value (index, out_value); end; return; %page; validate_value_seg: proc (vvs_value_seg_ptr); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl bc fixed bin (24); dcl vvs_code fixed bin (35); dcl vvs_value_seg_ptr ptr; dcl VALUE_SEG_NAME init ("xmail_data.value") char (32) var int static options (constant); /* Get the pointer to the value seg just before we use it */ vvs_value_seg_ptr = null; call initiate_file_ (rtrim(xmail_data.value_seg_pathname), (VALUE_SEG_NAME), RW_ACCESS, vvs_value_seg_ptr, bc, vvs_code); return; end validate_value_seg; validate_name_and_index: proc (vn_name, vn_index); dcl VN_NAME_ARRAY dim (1:21) char (25) int static options (constant) init ("acknowledge_yn ", "always_escape_keys_yn ", "confirm_print_yn ", "file_original_yn ", "include_original_yn ", "original_up_window_yn ", "msgs_as_mail_yn ", "interactive_msgs_yn ", "lists_as_menus_yn ", "multics_mode_yn ", "remove_menus_yn ", "save_mailfile ", "save_message_yn ", "version ", "dprint_heading ", "dprint_destination ", "dprint_request_type ", "dprint_copies ", "dprint_left_margin ", "dprint_notify ", "lifetime_first_invocation"); dcl vn_index fixed bin; dcl vn_name char (*); /* Now get the index to the table of names */ do vn_index = 1 to 21 while (VN_NAME_ARRAY (vn_index) ^= rtrim(vn_name)); end; return; end validate_name_and_index; %page; validate_returned_value: proc (vrv_index, vrv_out_value, vrv_code); dcl vrv_code fixed bin (35); dcl vrv_index fixed bin; dcl vrv_out_value char (*) var; dcl generic_type char (32); dcl non_number fixed bin; dcl TEST_VALUE_ARRAY dim (1:21) fixed bin int static options (constant) init (1,2,2,1,1,2,1,2,2,2,2,3,1,9,4,5,6,8,7,1,1); dcl NO init ("no") char (2) int static options (constant); dcl YES init ("yes") char (3) int static options (constant); dcl ASK init ("ask") char (3) int static options (constant); dcl INVALID_CHARS init (" <()[]{}*,;") char (12) int static options (constant); dcl VALID_LENGTH fixed bin init (32) int static options (constant); dcl error_table_$bigarg fixed bin(35) ext static; dcl error_table_$bad_arg fixed bin(35) ext static; dcl error_table_$smallarg fixed bin(35) ext static; dcl iod_info_$generic_type entry (char(*), char(32), fixed bin(35)); vrv_code = 0; goto OPTION (TEST_VALUE_ARRAY (vrv_index)); OPTION (1): /* yes_no_ask */ if ^(vrv_out_value = YES | vrv_out_value = NO | vrv_out_value = ASK) then vrv_code = error_table_$bad_arg; return; OPTION (2): /* yes_no */ if ^(vrv_out_value = YES | vrv_out_value = NO) then vrv_code = error_table_$bad_arg; return; OPTION (3): /* save messages in mailbox name */ if length (vrv_out_value) > VALID_LENGTH then code = error_table_$smallarg; else if search (vrv_out_value, INVALID_CHARS) ^= 0 then code = error_table_$bad_arg; return; OPTION (4): /* header */ if length(vrv_out_value) > 64 then vrv_code = error_table_$bigarg; return; OPTION (5): /* destination */ if length (vrv_out_value) < 0 | length (vrv_out_value) > 20 then vrv_code = error_table_$bigarg; return; OPTION (6): /* station */ if rtrim(vrv_out_value) = "default" then ; else do; if length(vrv_out_value) > 24 then code = error_table_$smallarg; else call iod_info_$generic_type ((vrv_out_value), generic_type, vrv_code); end; return; OPTION (7): /* margin */ non_number = verify (vrv_out_value, "-0123456789"); if non_number ^= 0 then vrv_code = error_table_$bad_arg; else if (fixed(vrv_out_value)) < 0 | (fixed(vrv_out_value)) > 20 then vrv_code = error_table_$bigarg; return; OPTION (8): /* copies */ non_number = verify (vrv_out_value, "-0123456789"); if non_number ^= 0 then vrv_code = error_table_$bad_arg; else if (fixed(vrv_out_value)) < 1 | (fixed(vrv_out_value)) > 30 then vrv_code = error_table_$bigarg; return; OPTION (9): /* no check */ return; end validate_returned_value; %page; get_default_value: proc (gdv_index, gdv_out_value); dcl gdv_index fixed bin; dcl gdv_out_value char (*) var; dcl GDV_DEFAULT_CLASS_ARRAY dim (1:21) fixed bin int static options (constant) init (1,1,2,1,1,2,1,2,1,1,1,3,2,4,5,5,5,5,5,1,1); goto OPTION (GDV_DEFAULT_CLASS_ARRAY (gdv_index)); OPTION (1): /* no */ gdv_out_value = "no"; return; OPTION (2): /* yes */ gdv_out_value = "yes"; return; OPTION (3): /* ask */ gdv_out_value = "ask"; return; OPTION (4): /* version */ gdv_out_value = xmail_version; return; OPTION (5): /* all other */ return; end get_default_value; %include xmail_data; %include access_mode_values; end xmail_value_;  xmail_window_manager_.pl1 09/02/88 0759.6r w 09/02/88 0745.0 237213 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-28,Blair), approve(86-02-26,MCR7358), audit(86-04-21,RBarstad), install(86-05-28,MR12.0-1062): Signal reissue_query from the quit handler so that the choice menu will be redrawn or the question the user quit out of will be reprompted after a quit or a disconnect. TRs 18711 18974. 2) change(87-02-10,Blair), approve(87-02-10,MCR7618), audit(87-04-15,RBarstad), install(87-04-26,MR12.1-1025): Adjust the screen after a reconnect so that we don't attempt to rebuild menus on a reply and we print the "Editing..." line when the menus are suppressed on a send. Error_list #114. END HISTORY COMMENTS */ xmail_window_manager_: proc (); /************************************************************************/ /* BEGIN DESCRIPTION function: This subroutine handles xmail window management. It contains the following entrypoints: create_windows -- creates the windows needed by xmail. These windows are created in the user_io window. destroy_windows -- destroys all of the windows created by the create_windows entrypoint. set_sw_size -- alters the size of the status window and has the surrounding windows compensate. set_menu_window_size -- alters the size of the menu window and has the surrounding windows compensate. reconnect -- resets the window status on all windows and redisplays the whole screen if it was found that there is "window status pending". reconnect_test -- like reconnect but also returns a bit indicating whether the current quit condition is a reconnect quit ("1"b = reconnect). quit_handler -- like reconnect_test but also queries the user if the quit is not a reconnect quit. Returns "1"b if the quit is not a reconnect AND if the user says he really wants to quit. suppress_menu -- resizes the bottom window to all but the size of the status window, which will display an editing message. The whole bottom window can then be used for editing. Used before call to emacs_. restore_menu -- restores the previous bottom window that was saved in suppress_menu. Used after call to emacs_. */ /************************************************************************/ /* history: Written 1/8/82 by Suzanne Krupp 83-07-28 DJ Schimke: Removed unreferenced dcl of video_data_$terminal_iocb. 83-09-14 DJ Schimke: Modified to save the original user_io iocb in xmail data rather than an internal static. This allows xmail_redisplay_ to clear xmail's portion of the user's screen. TR 12413 84-04-06 DJ Schimke: Corrected the reference to error_table_$badcall which was incorrectly spelled "bad_call". TR 17252 84-06-22 DJ Schimke: Changed xmail to resize user_i/o rather than syning user_i/o to xmail_bottom_window. This allows user specified keybindings and more prompts to be supported from within xmail. The code that cleared the overlapping regions after resizing the windows was simplified by a single call to clear the bottom window. xmail error list #92 84-09-20 JG Backs: Added 2 new entrypoints, suppress_menu and restore_menu, to support the new personalization option "Remove Menu While Editing". 84-11-13 JG Backs: Added a 1 bit input parameter "condition_signalled" to entrypoint destroy_windows, which is "1" if procedure is called during condition cleanup and "0" all other times. This bit is tested to prevent the screen from being cleared during a true cleanup condition. The xmail module was also modified because it calls this entrypoint when the user exits xmail, and the parameter indicates if screen output should be avoided. END DESCRIPTION */ /* PARAMETERS */ dcl code fixed bin (35); dcl new_window_height fixed bin parameter; /* AUTOMATIC */ dcl any_window_status_pending bit (1) aligned; dcl delta fixed bin; dcl np_code fixed bin (35); dcl reconnect_sw bit (1) aligned; dcl stack_ptr ptr; dcl yes_sw bit (1) aligned; dcl 1 auto_window_status_info aligned like window_status_info; dcl 1 bottom_window_info like window_position_info; dcl 1 cond_info like condition_info; dcl 1 menu_window_info like window_position_info; dcl 1 status_window_info like window_position_info; /* BUILTINS */ dcl (addr, null) builtin; /* ENTRIES */ dcl find_condition_frame_ entry (ptr) returns (ptr); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl window_$overwrite_text entry (ptr, char (*), fixed bin (35)); dcl window_$clear_window entry (ptr, fixed bin (35)); dcl window_$position_cursor entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl xmail_error_$no_code entry () options (variable); dcl xmail_error_$no_print entry () options (variable); dcl xmail_get_str_$yes_no entry (char (*) var, bit (1) aligned); dcl xmail_redisplay_$all entry (); dcl xmail_window_manager_$destroy_windows entry (bit (1)); /* CONSTANTS */ dcl COL1 fixed bin init (1) int static options (constant); dcl LINE1 fixed bin init (1) int static options (constant); dcl LOG char (1) init ("l") int static options (constant); dcl MAX_SW_HEIGHT fixed bin init (2) int static options (constant); dcl MENU_WINDOW_HEIGHT fixed bin init (1) int static options (constant); dcl MIN_SW_HEIGHT fixed bin init (1) int static options (constant); dcl NAME char (21) init ("xmail_window_manager_") int static options (constant); dcl STATUS_WINDOW_HEIGHT fixed bin init (1) int static options (constant); dcl XWMSM_HEADER char (45) init (" Editing...") int static options (constant); /* EXTERNAL STATIC */ dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$badcall fixed bin (35) ext static; dcl iox_$user_io ptr ext static; dcl video_data_$terminal_iocb ptr ext static; dcl video_et_$window_status_pending fixed bin (35) ext static; dcl xmail_err_$insuff_room_for_xmail fixed bin (35) ext static; /* INTERNAL STATIC */ dcl 1 user_io_window_info like window_position_info int static; /* BEGIN */ call xmail_error_$no_print (error_table_$badcall, NAME, LOG); create_windows: entry (code); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry creates the xmail windows in the user_io window. There are four xmail */ /* windows created: a status window (top), a multics mode status window (overlaps line */ /* 1 of status window), a menu window (middle), and a user_io window */ /* (bottom). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ code = 0; xmail_windows.status.iocb, xmail_windows.mm_status.iocb, xmail_windows.menu.iocb, xmail_windows.bottom.iocb = null; user_io_window_info.version = window_position_info_version; call iox_$control (iox_$user_io, "get_window_info", addr (user_io_window_info), code); if code ^= 0 then go to CREATE_EXIT; if user_io_window_info.height < xmail_windows.min_lines_needed then do; code = xmail_err_$insuff_room_for_xmail; go to CREATE_EXIT; end; call make_window ("xmail_status_window", /* window name */ user_io_window_info.line, /* line origin */ STATUS_WINDOW_HEIGHT, /* height */ user_io_window_info.width, /* width */ xmail_windows.status, /* window info */ code); if code ^= 0 then do; call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */ go to CREATE_EXIT; end; call make_window ("xmail_mm_status_window", /* window name */ user_io_window_info.line, /* line origin */ 1, /* height */ user_io_window_info.width, /* width */ xmail_windows.mm_status, /* window info */ code); if code ^= 0 then do; call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */ go to CREATE_EXIT; end; call make_window ("xmail_menu_window", user_io_window_info.line + STATUS_WINDOW_HEIGHT, MENU_WINDOW_HEIGHT, user_io_window_info.width, xmail_windows.menu, code); if code ^= 0 then do; call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */ go to CREATE_EXIT; end; xmail_windows.bottom.iocb = iox_$user_io; xmail_windows.bottom.position.version = window_position_info_version_1; xmail_windows.bottom.position.line = user_io_window_info.line + STATUS_WINDOW_HEIGHT + MENU_WINDOW_HEIGHT; xmail_windows.bottom.position.width = user_io_window_info.width; xmail_windows.bottom.position.height = user_io_window_info.height - (STATUS_WINDOW_HEIGHT + MENU_WINDOW_HEIGHT); call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), code); if code ^= 0 then do; call xmail_window_manager_$destroy_windows ("0"b); /* 0 = not cleanup condition */ go to CREATE_EXIT; end; CREATE_EXIT: return; /* create_windows entry */ destroy_windows: entry (condition_signalled); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry destroys all xmail windows. */ /* Input parameter indicates the following: */ /* condition_signalled = 1 to signal cleanup condition. */ /* condition_signalled = 0 to signal no condition. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* PARAMETERS */ dcl condition_signalled bit (1); /* input parameter */ /* 1 = cleanup condition */ /* 0 = no condition */ /* BEGIN */ xmail_windows.bottom.iocb = iox_$user_io; xmail_windows.bottom.position.version = window_position_info_version_1; xmail_windows.bottom.position.line = user_io_window_info.line; xmail_windows.bottom.position.width = user_io_window_info.width; xmail_windows.bottom.position.height = user_io_window_info.height; call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), (0)); /* Do not clear screen if cleanup condition was signalled */ if ^condition_signalled then call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore error */ call unmake_window (xmail_windows.status.iocb); call unmake_window (xmail_windows.mm_status.iocb); call unmake_window (xmail_windows.menu.iocb); return; /* destroy_windows entry */ set_sw_size: entry (new_window_height, code); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry sets the size of the status window taking or giving space from/to the */ /* menu window. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ code = 0; if new_window_height = xmail_windows.status.height then go to SET_SW_EXIT; if new_window_height < MIN_SW_HEIGHT | new_window_height > MAX_SW_HEIGHT then do; code = error_table_$bad_arg; go to SET_SW_EXIT; end; delta = new_window_height - xmail_windows.status.height; status_window_info = xmail_windows.status.position; status_window_info.height = status_window_info.height + delta; menu_window_info = xmail_windows.menu.position; menu_window_info.origin.line = menu_window_info.origin.line + delta; bottom_window_info = xmail_windows.bottom.position; bottom_window_info.height = bottom_window_info.height - delta; bottom_window_info.origin.line = bottom_window_info.origin.line + delta; call iox_$control (xmail_windows.status.iocb, "set_window_info", addr (status_window_info), code); if code ^= 0 then do; call reset_window_sizes (); go to SET_SW_EXIT; end; call iox_$control (xmail_windows.menu.iocb, "set_window_info", addr (menu_window_info), code); if code ^= 0 then do; call reset_window_sizes (); go to SET_SW_EXIT; end; call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), code); if code ^= 0 then do; call reset_window_sizes (); go to SET_SW_EXIT; end; call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore any error */ xmail_windows.status.position = status_window_info; xmail_windows.menu.position = menu_window_info; xmail_windows.bottom.position = bottom_window_info; SET_SW_EXIT: return; /* set_sw_size entry */ set_menu_window_size: entry (new_window_height, code); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry sets the size of the menu window taking or giving space to/from the */ /* bottom window. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ code = 0; if new_window_height = xmail_windows.menu.height then go to SET_MENU_EXIT; if new_window_height < 1 | new_window_height >= xmail_windows.menu.height + xmail_windows.bottom.height then do; code = error_table_$bad_arg; go to SET_MENU_EXIT; end; delta = new_window_height - xmail_windows.menu.height; menu_window_info = xmail_windows.menu.position; menu_window_info.height = menu_window_info.height + delta; bottom_window_info = xmail_windows.bottom.position; bottom_window_info.height = bottom_window_info.height - delta; bottom_window_info.origin.line = bottom_window_info.origin.line + delta; call iox_$control (xmail_windows.menu.iocb, "set_window_info", addr (menu_window_info), code); if code ^= 0 then do; call reset_window_sizes (); go to SET_MENU_EXIT; end; call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), code); if code ^= 0 then do; call reset_window_sizes (); go to SET_MENU_EXIT; end; call window_$clear_window (xmail_windows.bottom.iocb, (0)); /* ignore any error */ xmail_windows.menu.position = menu_window_info; xmail_windows.bottom.position = bottom_window_info; SET_MENU_EXIT: return; /* set_menu_window_size entry */ quit_handler: entry returns (bit (1) aligned); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is called by the xmail pl1 modules that call emacs_. It is called on a */ /* quit condition to protect the user from accidentally quitting before the current */ /* action is finished (ie. the message is not saved or sent.) It returns true only if */ /* the quit is not a reconnect quit and the user says yes to the prompt. Either way */ /* this entry also checks status pending for any of the windows and resets it. If any */ /* window had a status pending xmail_redisplay_$all is called to reset the display of */ /* all windows. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl reissue_query condition; call check_window_status; call check_for_reconnect (reconnect_sw); if reconnect_sw then do; yes_sw = "0"b; /* reconnect, don't quit */ signal reissue_query; end; else do; call xmail_get_str_$yes_no ("Any pending work will be lost." || " Do you really want to quit?", yes_sw); /* BREAK hit, query before quitting */ if ^yes_sw then signal reissue_query; end; return (yes_sw); reconnect: entry (); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is called to test for window status pending on the xmail windows and */ /* reset it on any window that needs resetting. If any window status is pending the */ /* xmail windows are redisplayed. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call check_window_status; return; /* reconnect entry */ reconnect_test: entry returns (bit (1) aligned); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is called only by the xmail emacs extensions to determine if the quit */ /* that they have detected is really a quit or whether it is actually a reconnect quit. */ /* It returns true if the quit is a reconnect quit, false otherwise. */ /* Either way this entry also checks status pending for any of the windows and resets */ /* it. If any window had a status pending xmail_redisplay_$all is called to reset the */ /* display of all windows. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl ioa_$ioa_switch_nnl entry() options(variable); dcl xmail_value_$get_with_default entry options(variable); dcl response char (3) var; call check_window_status; call check_for_reconnect (reconnect_sw); if reconnect_sw then do; if (xmail_data.remove_menus & ^xmail_data.reply_request) then do; call window_$clear_window (xmail_windows.status.iocb, (0)); call window_$overwrite_text (xmail_windows.status.iocb, XWMSM_HEADER, code); end; if xmail_data.reply_request then do; call xmail_value_$get_with_default ("original_up_window_yn", "yes", response, (0)); /* The following literal is found in xmail_reply_msg_ and must be duplicated here to make the screen look the same. It only appears when the original message is in an upper window and the reply is in a second window. */ if response = "yes" then call ioa_$ioa_switch_nnl (xmail_windows.menu.iocb, " *** Use ESC l to view previous page, ESC h to view next page ***"); end; end; return (reconnect_sw); /* reconnect_test entry */ suppress_menu: entry (); /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is called by xmail pl1 modules that call emacs_ with the */ /* personalization option "Remove Menu While Editing" in force. The only */ /* exception is xmail_reply_msgs_, since that always removes the menu. */ /* */ /* This entry resizes the bottom window so the previous window info can be */ /* restored via a call to another entrypoint, restore_menu, immediately */ /* after emacs_ call. By resizing the bottom window, emacs can use all */ /* but the status window to do the editing. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* AUTOMATIC */ dcl xwmsm_code fixed bin (35); /* CONSTANTS */ dcl XWMSM_ERROR char (31) init ("Cannot remove menu as requested") int static options (constant); /* BEGIN xmail_window_manager_$suppress_menu */ call window_$clear_window (xmail_windows.status.iocb, (0)); /* ignore code */ call window_$overwrite_text (xmail_windows.status.iocb, XWMSM_HEADER, xwmsm_code); if xwmsm_code ^= 0 then call xmail_error_$no_code (xwmsm_code, NAME, "s", XWMSM_ERROR); bottom_window_info = xmail_windows.bottom.position; delta = xmail_windows.menu.height + xmail_windows.status.height - 1; bottom_window_info.height = bottom_window_info.height + delta; bottom_window_info.origin.line = bottom_window_info.origin.line - delta; call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (bottom_window_info), xwmsm_code); if xwmsm_code ^= 0 then call xmail_error_$no_code (xwmsm_code, NAME, "s", XWMSM_ERROR); call window_$clear_window (iox_$user_io, (0)); /* ignore code */ suppress_menu_EXIT: return; /* suppress_menu entry */ restore_menu: entry (); /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This entry is used to restore the menu window by resizing the bottom */ /* window from the previous information. It is called immediately */ /* following the call to emacs_ in those xmail modules that use the editor.*/ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* AUTOMATIC */ dcl xwmrm_code fixed bin (35); /* BEGIN xmail_window_manager_$restore_menu */ call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), xwmrm_code); if xwmrm_code ^= 0 then call xmail_error_$no_code (xwmrm_code, NAME, "s", "Cannot restore menu information"); restore_menu_EXIT: return; /* restore_menu entry */ /* I N T E R N A L P R O C E D U R E S */ check_for_reconnect: proc (reconnect_quit); dcl reconnect_quit bit (1) aligned parameter; reconnect_quit = "0"b; cond_info.version = condition_info_version_1; cond_info.info_ptr = null (); cond_info.flags.pad1 = "0"b; cond_info.pad2 = "0"b; cond_info.pad3 = "0"b; stack_ptr = find_condition_frame_ (null ()); if stack_ptr ^= null () then do; call find_condition_info_ (stack_ptr, addr (cond_info), (0)); /* test cond_info.info_ptr rather than code */ if cond_info.info_ptr ^= null () then do; quit_info_ptr = cond_info.info_ptr; reconnect_quit = quit_info.switches.reconnection_quit; end; end; end check_for_reconnect; check_window_status: proc; any_window_status_pending = "0"b; call window_$position_cursor (xmail_windows.status.iocb, LINE1, COL1, np_code); if np_code = video_et_$window_status_pending then do; call fix_status (xmail_windows.status.iocb); any_window_status_pending = "1"b; end; else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG); call window_$position_cursor (xmail_windows.mm_status.iocb, LINE1, COL1, np_code); if np_code = video_et_$window_status_pending then do; call fix_status (xmail_windows.mm_status.iocb); any_window_status_pending = "1"b; end; else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG); call window_$position_cursor (xmail_windows.menu.iocb, LINE1, COL1, np_code); if np_code = video_et_$window_status_pending then do; call fix_status (xmail_windows.menu.iocb); any_window_status_pending = "1"b; end; else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG); call window_$position_cursor (xmail_windows.bottom.iocb, LINE1, COL1, np_code); if np_code = video_et_$window_status_pending then do; call fix_status (xmail_windows.bottom.iocb); any_window_status_pending = "1"b; end; else if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG); if any_window_status_pending then call xmail_redisplay_$all (); end check_window_status; fix_status: proc (P_iocb_ptr); dcl P_iocb_ptr ptr parameter; auto_window_status_info.version = window_status_version; call iox_$control (P_iocb_ptr, "get_window_status", addr (auto_window_status_info), np_code); if np_code ^= 0 then call xmail_error_$no_print (np_code, NAME, LOG); end; make_window: proc (name, line_origin, height, width, window, code); /* Automatic */ dcl code fixed bin (35); dcl height fixed bin; dcl line_origin fixed bin; dcl name char (*); dcl width fixed bin; dcl 1 window aligned like xmail_window_info_format; /* Builtin */ dcl (addr, null) builtin; /* Entry */ dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl window_$create entry (ptr, ptr, ptr, fixed bin (35)); window.iocb = null; window.position.version = window_position_info_version; window.position.line = line_origin; window.position.height = height; window.position.width = width; call iox_$find_iocb (name, window.iocb, code); if code = 0 then call window_$create (video_data_$terminal_iocb, addr (window.position), window.iocb, code); return; end make_window; unmake_window: proc (window_iocbp); /* Parameter */ dcl window_iocbp ptr; /* Builtin */ dcl null builtin; /* Entries */ dcl window_$destroy entry (ptr, fixed bin (35)); if window_iocbp ^= null then do; call window_$destroy (window_iocbp, (0)); /* ignore code */ window_iocbp = null; end; return; end unmake_window; reset_window_sizes: proc (); call iox_$control (xmail_windows.status.iocb, "set_window_info", addr (xmail_windows.status.position), (0)); /* ignore error */ call iox_$control (xmail_windows.menu.iocb, "set_window_info", addr (xmail_windows.menu.position), (0)); call iox_$control (xmail_windows.bottom.iocb, "set_window_info", addr (xmail_windows.bottom.position), (0)); end reset_window_sizes; %include condition_info; %page; %include condition_info_header; %page; %include quit_info; %page; %include xmail_windows; %page; %include window_status; %page; %include xmail_data; end xmail_window_manager_;  xmail_write_msgs_.pl1 09/02/88 0759.6r w 09/02/88 0744.7 97803 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ xmail_write_msgs_: proc (xwm_mailbox_ptr, xwm_curr_msgsp); /* BEGIN DESCRIPTION function: This procedure writes a copy of the current message(s) to a Multics segment in a format similar to that which is displayed with the "Display" request. It is executed when the "Write" request on either the "Process Incoming Mail" or "Process Filed Mail" menu is selected. description: The user is prompted for a file name. If the segment does not exist, it is created and the current message(s) are written to it. If it does exist, the current message(s) will be appended to the end. known bugs: This code does not check for the remote possibility that the user has rw permission on the segment to be written, but null access to the directory containing that segment. Call to adjust_bit_count_ will fail. JG Backs 84-07-18. history: 84-07-12 JG Backs: Written from xmail_dprint_msgs_.pl1 84-11-07 JG Backs: Deleted "This is an internal programming error." from the error message at the call to subroutine adjust_bit_count_. Audit change. END DESCRIPTION */ /* PARAMETERS */ dcl (xwm_mailbox_ptr, xwm_curr_msgsp) ptr; /* input pointers to mailbox and current messages */ /* EXTERNAL STATIC */ dcl error_table_$incorrect_access fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl xmail_err_$no_curr_msgs fixed bin (35) ext static; /* ENTRIES */ dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (35), fixed bin (35)); dcl delete_$ptr entry (ptr, bit (6) aligned, char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$append_branch entry (char (*), char (*), fixed bin (5), fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch_nnl entry () options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$destroy_iocb entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$user_io ptr ext static; dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl window_$clear_window entry (ptr, fixed bin (35)); dcl xmail_display_msgs_$ff entry (ptr, ptr, ptr); dcl xmail_error_$code_first entry () options (variable); dcl xmail_get_str_ entry (char (*) var, (*) char (*) var, char (*), char (*), char (*) var); dcl xmail_validate_$curr_msgs entry (ptr, fixed bin (35)); dcl xmail_validate_$mbx entry (ptr, fixed bin (35)); /* CONDITIONS */ dcl cleanup condition; /* QUIT handling */ /* INTERNAL AUTOMATIC */ dcl xwm_bit_count fixed bin (24); /* bit count of segment */ dcl xwm_code fixed bin (35); /* for output of status code during calls */ dcl xwm_dname char (168); /* directory of segment */ dcl xwm_ename char (32); /* entry name of segment */ dcl xwm_iocb_ptr ptr; /* pointer to control block for I/O switch */ dcl xwm_new_seg bit (1); /* flag; ON => new segment to be created */ dcl xwm_new_path char (200) varying;/* pathname of segment */ dcl xwm_seg_ptr ptr; /* pointer to segment */ dcl xwm_type fixed bin (2); /* for output of type during calls, not queried */ dcl xwm_unused_return_bc fixed bin (35); /* for output of bit count during calls, not queried */ /* CONSTANTS */ dcl xwm_CHASE fixed bin (1) init (1) int static options (constant); dcl xwm_DELETE_SEG bit (6) aligned init ("000100"b) int static options (constant); dcl xwm_FILE_PROMPT char (27) varying init ("Enter the name of the file:") int static options (constant); dcl xwm_LAST_CHAR bit (1) aligned init ("1"b) int static options (constant); dcl xwm_ME_CHAR char (17) init ("xmail_write_msgs_") int static options (constant); dcl xwm_ME_ENTRY entry init (xmail_write_msgs_) options (variable); dcl xwm_PATH_NAME char (9) init ("path_name") int static options (constant); dcl xwm_PROMPT_REPLIES_HELP char (28) init ("xmail_prompt_replies.gi.info") int static options (constant); dcl xwm_UNUSED_BIT bit (1) aligned init ("0"b) int static options (constant); /* BUILTINS */ dcl (codeptr, null, rtrim) builtin; %page; /* INCLUDE FILES */ %include access_mode_values; %page; %include iox_modes; %page; %include mlsys_mailbox; %page; %include mlsys_message; %page; %include xmail_curr_msg_info; %page; %include xmail_data; %page; %include xmail_responses; /* BEGIN */ xwm_iocb_ptr, xwm_seg_ptr = null; xwm_new_seg = "0"b; on cleanup call CLEANUP; /* Validate input parameters */ call xmail_validate_$mbx (xwm_mailbox_ptr, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Invalid mailbox structure. This is an internal programming error."); if xwm_curr_msgsp = null then call xmail_error_$code_first (xmail_err_$no_curr_msgs, xwm_ME_CHAR, "i"); else do; call xmail_validate_$curr_msgs (xwm_curr_msgsp, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Invalid message structure. This is an internal programming error."); end; curr_msgsp = xwm_curr_msgsp; mailbox_ptr = xwm_mailbox_ptr; /* Request input of file name (segment) */ xwm_new_path = ""; do while (xwm_new_path = ""); call xmail_get_str_ (xwm_FILE_PROMPT, "", xwm_PROMPT_REPLIES_HELP, xwm_PATH_NAME, xwm_new_path); if xwm_new_path = "" then call ioa_ ("^/ You must provide a file name."); if xwm_new_path = LIST then do; call ioa_ ("^/ A list of all possible files you can write to is not available with ??"); xwm_new_path = ""; end; end; /* do while */ call expand_pathname_ ((xwm_new_path), xwm_dname, xwm_ename, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ ""^a"" is not a valid file name.", xwm_new_path); /* Determine status of segment name */ call hcs_$status_minf (xwm_dname, xwm_ename, xwm_CHASE, xwm_type, xwm_bit_count, xwm_code); if xwm_code ^= 0 then do; if xwm_code = error_table_$noentry then do; /* Segment does not exist; create new segment */ xwm_new_seg = "1"b; call hcs_$append_branch (xwm_dname, xwm_ename, RW_ACCESS_BIN, xwm_code); if xwm_code ^= 0 then if xwm_code = error_table_$incorrect_access then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ You do not have correct access to directory ""^a"" to create file ""^a"".", xwm_dname, xwm_ename); else call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Unable to create new file ""^a"" in directory ""^a"".", xwm_ename, xwm_dname); end; else if xwm_code = error_table_$incorrect_access then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ You do not have correct access to file ""^a"" in directory ""^a"".", xwm_ename, xwm_dname); else call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ There is an error with file ""^a"" in directory ""^a"".", xwm_ename, xwm_dname); end; /* do */ /* Now try to write to segment */ call initiate_file_ (xwm_dname, xwm_ename, RW_ACCESS, xwm_seg_ptr, xwm_bit_count, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Unable to initiate file ""^a"" in directory ""^a"".", xwm_ename, xwm_dname); call iox_$attach_name (unique_chars_ ("0"b), xwm_iocb_ptr, "vfile_ " || rtrim (xwm_dname) || ">" || (xwm_ename) || " -extend", codeptr (xwm_ME_ENTRY), xwm_code); if xwm_code = 0 then call iox_$open (xwm_iocb_ptr, Stream_input_output, xwm_UNUSED_BIT, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Unable to prepare output switch to file. This is an internal programming error."); if ^xwm_new_seg then call ioa_$ioa_switch_nnl (xwm_iocb_ptr, "^|"); call xmail_display_msgs_$ff (mailbox_ptr, curr_msgsp, xwm_iocb_ptr); call adjust_bit_count_ ((xwm_dname), (xwm_ename), xwm_LAST_CHAR, xwm_unused_return_bc, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Unable to adjust bit count of file."); /* Complete by destroying I/O control block pointer, clearing screen, & writing message to user */ call close_detach_and_destroy (xwm_iocb_ptr); call window_$clear_window (iox_$user_io, xwm_code); if xwm_code ^= 0 then call xmail_error_$code_first (xwm_code, xwm_ME_CHAR, "q", "^/ Unable to clear window. This is an internal programming error."); call ioa_ ("Message^[s^] ^v(^d ^)^[written^;appended^] to ^a.", (curr_msgs.count > 1), curr_msgs.count, curr_msgs.numbers, xwm_new_seg, xwm_ename); return; %page; /* Internal procedures */ close_detach_and_destroy: proc (cdad_iocb_ptr); /* Internal procedure to finish with the control block pointer for the I/O switch */ /* PARAMETERS */ dcl cdad_iocb_ptr ptr; /* input pointer to I/O control block */ /* BEGIN */ if cdad_iocb_ptr ^= null then do; call iox_$close (cdad_iocb_ptr, (0)); /* ignore code */ call iox_$detach_iocb (cdad_iocb_ptr, (0)); /* ignore code */ call iox_$destroy_iocb (cdad_iocb_ptr, (0)); /* ignore code */ end; end close_detach_and_destroy; CLEANUP: proc; /* Internal procedure for cleanup condition: to delete non-null segment pointer if a new file, or restore bit count if existing file */ /* BEGIN */ call close_detach_and_destroy (xwm_iocb_ptr); if xwm_seg_ptr ^= null then if xwm_new_seg then do; call delete_$ptr (xwm_seg_ptr, xwm_DELETE_SEG, "", xwm_code); if xwm_code = 0 then xwm_seg_ptr = null; end; else call hcs_$set_bc (xwm_dname, xwm_ename, xwm_bit_count, (0)); /* ignore code */ end CLEANUP; end xmail_write_msgs_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved