e_mail_pl1_.pl1 04/24/89 1350.4rew 04/24/89 1340.5 232281 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(88-03-22,Blair), approve(88-03-22,MCR7842), audit(88-06-29,Lippard), install(88-07-26,MR12.2-1069): Add a new entry to expand the savebox pathname after searching the mlsys searchlist for the user supplied savebox name. 2) change(89-02-09,Flegel), approve(89-03-16,MCR8076), audit(89-03-30,Lee), install(89-04-24,MR12.3-1035): Moved system procedure, support, and parameter declarations out of entry points and into the main procedure declaration. phx16782 - created entries emacs_get_address_list and emacs_redistribute_message for rmail-forward support 3) change(89-02-16,Flegel), approve(89-03-16,MCR8076), audit(89-03-30,Lee), install(89-04-24,MR12.3-1035): phx21262 - support for getting and modifying the "seen" switch on messages END HISTORY COMMENTS */ /* * 83/07/19 Jon A. Rochlis - RMAIL pl1 interface to MR10.2 mail_system_ * 83/01/06 B. Margolin - to not set deliver_options.queue_mailing_lists. */ e_mail_pl1_: proc(); /* PARAMETERS */ dcl a_addr char (*) parameter; /* Addresses to parse */ dcl a_addr_ptr ptr parameter; /* Address list created */ dcl a_code fixed bin (35) parameter; /* Error code */ dcl a_comments char (*) parameter; /* Comments to add */ dcl a_recipients_ptr ptr parameter; /* Forward addresses */ dcl a_acknowledge_flag bit (1) parameter; /* Ack requested */ dcl a_error_ptr ptr parameter; /* Pointer to error structures */ dcl a_seen_sw bit (1) parameter; /* Message seen switch */ dcl a_mbx_dir char (*) parameter; dcl a_mbx_entry char (*) parameter; dcl a_mailbox_ptr ptr parameter; dcl a_salvaged bit(1) aligned parameter; dcl a_msgcount fixed bin parameter; dcl a_message_ptr ptr parameter; dcl a_buffer_ptr ptr parameter; dcl a_envelope_format char(*) parameter; dcl a_header_format char(*) parameter; dcl a_redistributions_list_format char(*) parameter; dcl a_body_length fixed bin(21) parameter; dcl a_line_length fixed bin parameter; dcl a_message_number fixed bin parameter; dcl a_subject char(*) parameter; dcl a_original_message_ptr ptr parameter; dcl a_new_message_ptr ptr parameter; dcl a_include_authors bit(1) parameter; dcl a_include_recipients bit(1) parameter; dcl a_include_self bit(1) parameter; dcl a_message_text char(*) parameter; dcl a_parse_error_list_ptr ptr parameter; dcl a_request_ack bit(1) parameter; dcl a_pathname char (*) parameter; dcl a_dirname char (168) parameter; dcl a_entryname char (32) parameter; /* SYSTEM CALLS */ dcl mail_system_$redistribute_message entry (ptr, char (*), ptr, ptr, fixed bin (35)); dcl mail_system_$open_mailbox entry (char (*), char(*), ptr, char(8), 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_$close_mailbox entry (ptr, ptr, fixed bin(35)); dcl mail_system_$free_address_list entry (ptr, fixed bin (35)); dcl mail_system_$create_message entry (char (8), ptr, fixed bin(35)); dcl mail_system_$create_address_list entry (char (8), ptr, fixed bin(35)); dcl mail_system_$add_address entry (ptr, ptr, char(8), fixed bin(35)); dcl mail_system_$replace_subject entry (ptr, char (*), fixed bin(35)); dcl mail_system_$replace_from entry (ptr, ptr, fixed bin(35)); dcl mail_system_$deliver_message entry (ptr, ptr, ptr, fixed bin(35)); dcl mail_system_$free_message entry (ptr, fixed bin(35)); dcl mlsys_utils_$format_message entry (ptr, ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl mlsys_utils_$parse_address_list_text entry (char (*), ptr, char (8), ptr, ptr, fixed bin (35)); dcl mlsys_utils_$create_reply_message entry (ptr, ptr, ptr, fixed bin(35)); dcl mlsys_utils_$format_message_header entry (ptr, fixed bin, fixed bin, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); dcl mlsys_utils_$parse_message_text entry (char (*), ptr, char (8), 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 user_info_$login_data entry (char(*), char(*), char(*), fixed bin, fixed bin, fixed bin, fixed bin(71), char(*)); dcl get_system_free_area_ entry() returns(ptr); dcl com_err_$suppress_name entry options (variable); dcl ssu_$standalone_invocation entry (ptr, char(*), char(*), ptr, entry, fixed bin(35)); dcl ssu_$destroy_invocation entry (ptr); dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35)); dcl search_paths_$find_dir entry (char(*), ptr, char(*), char(*), char(*), fixed bin(35)); /* SYSTEM CALL SUPPORT */ dcl error_table_$noentry fixed bin(35) ext static; dcl mlsys_et_$cant_parse_irt_field fixed bin(35) ext static; dcl sys_info$max_seg_size fixed bin(35) ext static; dcl mlsys_data_$user_default_mailbox_address ptr ext static; dcl mlsys_data_$user_mail_table_address ptr ext static; /* EXTERNAL CALLS */ dcl e_mail_pl1_$get_user_default_address entry returns(ptr); /* BUILTINS */ dcl (addr, index, length, null, reverse, rtrim, translate, substr, unspec, search) builtin; /* CONDITIONS */ dcl clean_up condition; return; /* Open a mailbox for later reading. Pass back a pointer to the mailbox structure to be used during later reads */ emacs_mailbox_open: entry(a_mbx_dir, a_mbx_entry, a_mailbox_ptr, a_salvaged, a_msgcount, a_code); dcl 1 auto_open_options aligned like open_options; a_code = 0; unspec (auto_open_options) = ""b; auto_open_options.version = OPEN_OPTIONS_VERSION_2; 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 (a_mbx_dir, a_mbx_entry, addr(auto_open_options), MAILBOX_VERSION_2, a_mailbox_ptr, a_code); if a_code ^= 0 then return; a_salvaged = a_mailbox_ptr -> mailbox.flags.salvaged; a_msgcount = a_mailbox_ptr -> mailbox.n_messages; return; /* end emacs_open_mailbox; */ /* Read one message. We are given a pointer to a mail system message, and we use the mail system to format it. RMAIL will expect to find the formatted message in a black magic string pointed to by a_buffer_ptr */ emacs_read_message: entry (a_message_ptr, a_buffer_ptr, a_line_length, a_acknowledge_flag, a_envelope_format, a_header_format, a_redistributions_list_format, a_body_length, a_seen_sw, a_code); dcl buffer_position fixed bin(21); dcl 1 auto_format_options aligned like format_message_options; dcl chrsused fixed bin(35) based; /* ugh, ugh ... shades of Scribe */ a_code = 0; unspec (auto_format_options) = ""b; auto_format_options.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; auto_format_options.line_length = a_line_length; auto_format_options.include_body = "1"b; call parse_formatting_mode (a_envelope_format, auto_format_options.envelope_formatting_mode, a_code); if a_code ^= 0 then do; a_code = -1; return; end; call parse_formatting_mode (a_header_format, auto_format_options.header_formatting_mode, a_code); if a_code ^= 0 then do; a_code = -2; return; end; call parse_formatting_mode (a_redistributions_list_format, auto_format_options.redistributions_list_formatting_mode, a_code); if a_code ^= 0 then do; a_code = -3; return; end; buffer_position = 4; /* 4 chars = 1 word, leaves room for the bmstr length */ call mlsys_utils_$format_message (a_message_ptr, addr (auto_format_options), a_buffer_ptr, (sys_info$max_seg_size-1)*4, buffer_position, a_code); if a_code ^= 0 then return; a_buffer_ptr -> chrsused = buffer_position - 4; a_body_length = a_message_ptr -> message.body.total_lines; if a_message_ptr -> message.flags.must_be_acknowledged & a_acknowledge_flag then call mail_system_$acknowledge_message (a_message_ptr, a_code); a_seen_sw = a_message_ptr -> message.flags.seen; return; parse_formatting_mode: proc (a_formatting_mode, a_mlsys_formatting_mode, a_code); dcl a_formatting_mode char(*) parameter; dcl a_mlsys_formatting_mode fixed bin parameter; dcl a_code fixed bin (35) parameter; a_code = 0; a_formatting_mode = translate (a_formatting_mode, "_", "-"); /* allow either underscrose or dashes */ if a_formatting_mode = "none_formatting_mode" then a_mlsys_formatting_mode = NONE_FORMATTING_MODE; else if a_formatting_mode = "brief_formatting_mode" then a_mlsys_formatting_mode = BRIEF_FORMATTING_MODE; else if a_formatting_mode = "default_formatting_mode" then a_mlsys_formatting_mode = DEFAULT_FORMATTING_MODE; else if a_formatting_mode = "long_formatting_mode" then a_mlsys_formatting_mode = LONG_FORMATTING_MODE; else a_code = -1; /* this will be special cased by RMAIL */ end parse_formatting_mode; /* end emacs_read_message; */ /* Given a pointer to a mailbox, and a message number, return a pointer to that message (reading it if need be). */ emacs_get_message_ptr: entry (a_mailbox_ptr, a_message_number, a_message_ptr, a_code); a_code = 0; a_message_ptr = a_mailbox_ptr -> mailbox.messages(a_message_number).message_ptr; if a_message_ptr = null then do; call mail_system_$read_message (a_mailbox_ptr, a_message_number, a_code); if a_code ^= 0 then return; a_message_ptr = a_mailbox_ptr -> mailbox.messages(a_message_number).message_ptr; end; return; /* Close a mailbox */ emacs_mailbox_close: entry (a_mailbox_ptr, a_code); dcl 1 auto_close_options aligned like close_options; a_code = 0; unspec (auto_close_options) = ""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; /* I'm not about to set up a sub_err_ handler */ call mail_system_$close_mailbox (a_mailbox_ptr, addr (auto_close_options), a_code); return; /* end emacs_mailbox_close; */ get_user_default_address: entry returns(ptr); dcl anonymous fixed bin; call user_info_$login_data ("", "", "", anonymous, (0), (0), (0), ""); if anonymous = 1 then return (mlsys_data_$user_default_mailbox_address); else return (mlsys_data_$user_mail_table_address); /* end get_user_default_address; */ get_user_default_mbx_address: entry returns (ptr); return (mlsys_data_$user_default_mailbox_address); /* end get_user_default_mbx_address; */ /* Create an address list from a character string representation of a list of addresses. */ emacs_get_address_list: entry (a_addr, a_addr_ptr, a_error_ptr, a_code); dcl 01 pt_ops like parse_text_options aligned; /* Prepare for cleanup condition */ a_code = 0; a_addr_ptr = null; a_error_ptr = null; on clean_up begin; if a_addr_ptr ^= null then call mail_system_$free_address_list (a_addr_ptr, (0)); if a_error_ptr ^= null then call free_parse_text_error_list (a_error_ptr); end; /* Parse the forwarding destination addresses */ pt_ops.version = PARSE_TEXT_OPTIONS_VERSION_1; pt_ops.area_ptr = get_system_free_area_ (); pt_ops.list_errors = "1"b; pt_ops.validate_addresses = "1"b; pt_ops.include_invalid_addresses = "0"b; pt_ops.mbz = ""b; call mlsys_utils_$parse_address_list_text ((a_addr), addr (pt_ops), ADDRESS_LIST_VERSION_2, a_addr_ptr, a_error_ptr, a_code); if a_code ^= 0 then do; if a_addr_ptr ^= null then do; call mail_system_$free_address_list (a_addr_ptr, (0)); a_addr_ptr = null; end; return; end; return; /* end emacs_get_address_list */ emacs_create_message: entry (a_subject, a_message_ptr, a_code); dcl from_list ptr; a_code = 0; call mail_system_$create_message (MESSAGE_VERSION_2, a_message_ptr, a_code); if a_code ^= 0 then return; call mail_system_$replace_subject (a_message_ptr, a_subject, a_code); if a_code ^= 0 then return; /* Do the from field hacking to insure that we see the from field in the buffer. mail_system_ would wait until delivery time to fill it in. */ call mail_system_$create_address_list (ADDRESS_LIST_VERSION_2, from_list, a_code); if a_code ^= 0 then return; call mail_system_$add_address (from_list, e_mail_pl1_$get_user_default_address(), ADDRESS_LIST_VERSION_2, a_code); if a_code ^= 0 then return; call mail_system_$replace_from (a_message_ptr, from_list, a_code); return; /* end emacs_create_message; */ emacs_create_reply_message: entry (a_original_message_ptr, a_include_authors, a_include_recipients, a_include_self, a_new_message_ptr, a_code); dcl 1 auto_reply_options aligned like reply_options; a_code = 0; unspec (auto_reply_options) = ""b; auto_reply_options.version = REPLY_OPTIONS_VERSION_2; auto_reply_options.to = null; /* no extra recipients */ auto_reply_options.cc = null; auto_reply_options.bcc = null; auto_reply_options.flags.include_authors = a_include_authors; auto_reply_options.flags.include_recipients = a_include_recipients; auto_reply_options.flags.include_self = a_include_self; call mlsys_utils_$create_reply_message (a_original_message_ptr, addr (auto_reply_options), a_new_message_ptr, a_code); /* See create_message for the explanation of why we do this */ call mail_system_$create_address_list (ADDRESS_LIST_VERSION_2, from_list, a_code); if a_code ^= 0 then return; call mail_system_$add_address (from_list, e_mail_pl1_$get_user_default_address(), ADDRESS_LIST_VERSION_2, a_code); if a_code ^= 0 then return; call mail_system_$replace_from (a_new_message_ptr, from_list, a_code); return; /* end emacs_create_reply_message; */ emacs_format_header: entry (a_message_ptr, a_line_length, a_buffer_ptr, a_code); a_code = 0; buffer_position = 4; /* see emacs_read_message for black magic string hacking */ call mlsys_utils_$format_message_header (a_message_ptr, DEFAULT_FORMATTING_MODE, a_line_length, a_buffer_ptr, (sys_info$max_seg_size-1)*4, buffer_position, a_code); if a_code ^= 0 then return; a_buffer_ptr -> chrsused = buffer_position - 4; return; /* end emacs_format_header; */ emacs_parse_message_text: entry (a_message_text, a_message_ptr, a_parse_error_list_ptr, a_code); dcl 1 auto_parse_options aligned like parse_text_options; a_code = 0; unspec(auto_parse_options) = ""b; auto_parse_options.version = PARSE_TEXT_OPTIONS_VERSION_1; auto_parse_options.area_ptr = null; /* system_free_area_ is fine */ auto_parse_options.flags.list_errors = "1"b; auto_parse_options.flags.validate_addresses = "1"b; /* ???? */ auto_parse_options.flags.include_invalid_addresses = "1"b; /* ???? */ call mlsys_utils_$parse_message_text (a_message_text, addr (auto_parse_options), MESSAGE_VERSION_2, a_message_ptr, a_parse_error_list_ptr, a_code); /* If the only error was not being able to parse the In-Reply-To: field, we pretend everything was okay, since RMAIL will add the reply reference itself and considers parse errors to be fatal. */ if a_parse_error_list_ptr = null then return; if a_parse_error_list_ptr -> parse_text_error_list.n_errors = 1 then do; if a_parse_error_list_ptr -> parse_text_error_list.errors(1).code = mlsys_et_$cant_parse_irt_field then a_code = 0; end; return; /* end emacs_parse_message_text; */ /* display the parse error list (from above) via com_err_ */ display_parse_errors: entry (a_parse_error_list_ptr, a_message_text); dcl 1 ptel aligned like parse_text_error_list based (a_parse_error_list_ptr); dcl i fixed bin; begin; dcl code fixed bin(35), (start, length) fixed bin(21); do i = 1 to ptel.n_errors; code = ptel.errors(i).code; start = ptel.errors(i).text_start; length = ptel.errors(i).text_lth; if code ^= mlsys_et_$cant_parse_irt_field then call com_err_$suppress_name (code, "emacs (rmail)", substr (a_message_text, start, length)); end; /* do */ end; /* begin */ return; /* end display_parse_errors; */ free_parse_text_error_list: entry (a_parse_error_list_ptr); dcl free_area area based; free ptel in (get_system_free_area_() -> free_area); return; /* end display_parse_errors; */ /* Deliver a message and print the delivery results on user_i/o (RMAIL has set up a file output) */ emacs_deliver_message: entry (a_message_ptr, a_request_ack, a_code); dcl sci_ptr ptr; dcl delivery_code fixed bin (35); dcl 1 auto_deliver_options aligned like deliver_options; delivery_code = 0; sci_ptr, recipients_info_ptr = null; /* for cleanup handler */ unspec (auto_deliver_options) = ""b; recipients_info_n_lists = 3; on clean_up call free_structures("1"b); allocate recipients_info set (recipients_info_ptr); recipients_info.header.version = RECIPIENTS_INFO_VERSION_2; recipients_info.header.area_ptr = get_system_free_area_ (); recipients_info.header.expanded_recipients_result_list_ptr = null; recipients_info.lists.recipients_result_list_ptr = null; recipients_info.lists.address_list_ptr(1) = a_message_ptr -> message.header.to; recipients_info.lists.address_list_ptr(2) = a_message_ptr -> message.header.cc; recipients_info.lists.address_list_ptr(3) = a_message_ptr -> message.header.bcc; 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 = "1"b; /* ???? */ auto_deliver_options.flags.recipient_notification = "1"b; auto_deliver_options.flags.acknowledge = a_request_ack; auto_deliver_options.flags.queue_mailing_lists = "0"b; /* ???? */ call mail_system_$deliver_message (a_message_ptr, recipients_info_ptr, addr (auto_deliver_options), delivery_code); if delivery_code ^= 0 then call com_err_$suppress_name (delivery_code, "", ""); /* print_delivery_results will yield more info */ /* Now it's time to print the results */ call ssu_$standalone_invocation (sci_ptr, "", "", null, ssu_abort_deliver, a_code); if a_code ^= 0 then do; call com_err_$suppress_name (a_code, "", "While creating an ssu_ stand alone invocation."); call free_structures("1"b); return; end; call mlsys_utils_$print_delivery_results (sci_ptr, "0"b /* print all results */, recipients_info_ptr, a_code); if a_code ^= 0 then do; call com_err_$suppress_name (a_code, "", "While printing delivery results."); end; a_code = delivery_code; /* at this point a_code must be 0, but we want to make sure RMAIL knows something happened if deliver message got an error */ ERROR_DELIVER_RETURN: call free_structures ("1"b); return; ssu_abort_deliver: /* ssu wants a proc which really aborts */ proc; goto ERROR_DELIVER_RETURN; end ssu_abort_deliver; ssu_abort_redistribute: proc; goto ERROR_REDIST_RETURN; end ssu_abort_redistribute; free_structures: proc (a_message_flag); dcl a_message_flag bit (1) parameter; /* If a message is to be cleaned */ if a_message_flag then call mail_system_$free_message (a_message_ptr, (0)); if recipients_info_ptr ^= null then do; call mlsys_utils_$free_delivery_results (recipients_info_ptr, (0)); /* only frees expanded lists in the structure */ free recipients_info; end; if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); return; end free_structures; /* end emacs_deliver_message; */ /* Redistribute the message, with the comments provided and the appropriate acknowledgement to the provided list of address(es). */ emacs_redistribute_message: entry (a_message_ptr, a_comments, a_recipients_ptr, a_acknowledge_flag, a_code); dcl 01 dv_ops like deliver_options aligned; dcl system_free_area_ptr ptr; dcl system_free_area area based (system_free_area_ptr); dcl redist_code fixed bin (35); /* Prepare for cleanup condition */ system_free_area_ptr = get_system_free_area_ (); recipients_info_ptr = null; sci_ptr = null; on clean_up call free_structures ("0"b); /* Set up the recipients info structure (those to forward to) */ recipients_info_n_lists = 1; allocate recipients_info set (recipients_info_ptr) in (system_free_area); recipients_info.header.version = RECIPIENTS_INFO_VERSION_2; recipients_info.header.area_ptr = system_free_area_ptr; recipients_info.header.expanded_recipients_result_list_ptr = null; recipients_info.n_recipients = 0; recipients_info.n_unique_recipients = 0; recipients_info.n_failed_recipients = 0; recipients_info.n_lists = 1; recipients_info.lists(1).address_list_ptr = a_recipients_ptr; recipients_info.lists(1).recipients_result_list_ptr = null; dv_ops.version = DELIVER_OPTIONS_VERSION_2; dv_ops.delivery_mode = ORDINARY_DELIVERY; dv_ops.queueing_mode = ALWAYS_QUEUE_FOREIGN; dv_ops.queued_notification_mode = NOTIFY_ON_ERROR; dv_ops.abort = "1"b; dv_ops.flags.send_if_empty = "1"b; dv_ops.flags.recipient_notification = "1"b; dv_ops.flags.acknowledge = a_acknowledge_flag; dv_ops.flags.queue_mailing_lists = "0"b; dv_ops.flags.mbz = ""b; call mail_system_$redistribute_message (a_message_ptr, a_comments, recipients_info_ptr, addr (dv_ops), redist_code); if redist_code ^= 0 then call com_err_$suppress_name (redist_code, "", ""); /* print_delivery_results will yield more info */ /* Now it's time to print the results */ call ssu_$standalone_invocation (sci_ptr, "", "", null, ssu_abort_redistribute, a_code); if a_code ^= 0 then do; call com_err_$suppress_name (a_code, "", "While creating an ssu_ stand alone invocation."); call free_structures("0"b); return; end; call mlsys_utils_$print_delivery_results (sci_ptr, "0"b /* print all results */, recipients_info_ptr, a_code); if a_code ^= 0 then do; call com_err_$suppress_name (a_code, "", "While printing delivery results."); end; a_code = redist_code; /* at this point a_code must be 0, but we want to make sure RMAIL knows something happened if deliver message got an error */ ERROR_REDIST_RETURN: call free_structures ("0"b); return; /* end emacs_redistribute_message */ /* Expand the name of the savebox the user types in. If there are no "<>" characters in the pathname, then look in the "mlsys" searchlist for the entryname. */ emacs_expand_svbx_pathname: entry (a_pathname, a_dirname, a_entryname, a_code); dcl pathname char (168); dcl dirname char (168); dcl entryname char (32); dcl code fixed bin (35); a_code, code = 0; pathname = a_pathname; entryname, dirname = ""; /* strip off the .sv if necessary */ if index (reverse (rtrim(pathname)), reverse (".sv")) = 1 then pathname = substr (pathname, 1, length(rtrim(pathname)) - length(".sv")); if search (pathname, "<>") = 0 then do; call suffixed_name_$make (rtrim(pathname), "sv.mbx", entryname, code); if code ^= 0 then do; call com_err_$suppress_name (code, "", "Expanding savebox pathname."); goto EXIT_SVBX_PATHNAME; end; call search_paths_$find_dir ("mlsys", null, rtrim(entryname), "", dirname, code); if code ^= 0 then if code = error_table_$noentry then do; call expand_pathname_$add_suffix (pathname, "sv.mbx", dirname, entryname, code); if code ^= 0 then do; call com_err_$suppress_name (code, "", "Expanding savebox pathname."); goto EXIT_SVBX_PATHNAME; end; end; else call com_err_$suppress_name (code, "", "Searching ""mlsys"" searchlist."); else; end; else do; call expand_pathname_$add_suffix (pathname, "sv.mbx", dirname, entryname, code); if code ^= 0 then call com_err_$suppress_name (code, "", "Expanding savebox pathname."); end; EXIT_SVBX_PATHNAME: a_dirname = dirname; a_entryname = entryname; a_code = code; return; /* end emacs_expand_svbx_pathname; */ %include mlsys_open_options; %include mlsys_mailbox; %include mlsys_format_options; %include mlsys_close_options; %include mlsys_message; %include mlsys_parse_txt_options; %include mlsys_deliver_info; %include mlsys_reply_options; %include mlsys_address_list; %include rdm_switch_types; end e_mail_pl1_;  emacs_rmail_.lisp 04/24/89 1350.4rew 04/24/89 1341.0 470979 ;;; ****************************************************** ;;; * * ;;; * Copyright, (C) Honeywell Bull Inc., 1988 * ;;; * * ;;; * Copyright (c) 1978 by Massachusetts Institute of * ;;; * Technology and Honeywell Information Systems, Inc. * ;;; * * ;;; ****************************************************** ;;; HISTORY COMMENTS: ;;; 1) change(88-03-22,Blair), approve(88-03-22,MCR7842), ;;; audit(88-06-29,Lippard), install(88-07-26,MR12.2-1069): ;;; Change the expand_pathname_ to a call to ;;; e_mail_pl1_$emacs_expand_svbx_pathname on a copy request so that we ;;; can search the mlsys searchlist to locate the savebox. ;;; 2) change(89-02-02,Flegel), approve(89-02-28,MCR8066), ;;; audit(89-03-30,Lee), install(89-04-24,MR12.3-1035): ;;; phx20937, phx21049 - Changed "create-file" calls to "open-file" calls. ;;; phx17317 - rmail-reply to change the Ack minor mode to the appropriate ;;; value when reusing a reply buffer. ;;; 3) change(89-02-13,Flegel), approve(89-03-16,MCR8076), ;;; audit(89-03-30,Lee), install(89-04-24,MR12.3-1035): ;;; phx18781 - addition of rmail-help bound to the "?" key in order to ;;; provide internal help to rmail. ;;; phx16782 - addition of rmail-forward bound to the "L" key in order ;;; to provide an interface for mail forwarding ;;; phx19704 - addition of support for rmail-quit so that if a rmail ;;; command has has been entered after new mail has arrived, then do not ;;; query. ;;; phx21262 - addition of rmail-toggle-seen bound to "X" key in order ;;; to provide an interface into changing the "seen" switch. ;;; END HISTORY COMMENTS ;;; ;;; Emacs nuntio, BSG 10/10/78, 12/15/78, 3/17/79 ;;; Major rewrite of whole emacs_rmail_ 10/19/80 BSG for real header parse ;;; To CAH's mlsys, BSG 10/31/82, reformat headers BSG 11/6/82 ;;; For MR10.2 mlsys by Jon Rochlis, July 1983 (for psr) ;;; To comment out register-option forms, and move them to e_option_defaults_, 1/19/84 Barmar. ;;; To make send-mail-beargumented trim the buffer name, 1/19/84 Barmar. ;;; To remove "rmail-check-if-in-rmail" from rmail-logger-*pend, as they ;;; are callable from send-mail, too. 2/15/85 Barmar ;;; Here begins Emacs send mail (SMAIL?) (defprop rtrim e_lap_$rtrim expr) (declare (*expr e$get_temporary_seg e$release_temporary_seg uppercase e_lap_$make-dat-ol-black-magic-string open-file execute-command exists-file fill-mode indent-rigidly save-same-file untabify exists-buffer delete-white-sides get-key-binding get-key-name describe)) (declare (*lexpr send-mail-beargumented)) (declare (special rmail-original-buffer mail-header-buffer fill-column mail-original-message-ptr mail-mark mail-request-ack screenlinelen rmail-request-acknowledgement null-pointer mail-address-ptr rmail-commands-since-new-mail)) (%include e-macros) (%include defun) ; for send-mail-beargumented (defvar mail-mode-hook nil) (defvar rmail-initialized nil) ;;; defpl1's for the send mail side (declare (defpl1 mail_system_$set_message_switch "" (ptr) (char (4) aligned) (bit (1) aligned) ;; message-ptr switch-name ("SEEN") switch-value (return fixed bin (35.)))) ;; code (declare (defpl1 e_mail_pl1_$emacs_redistribute_message "" (ptr) (char (*)) (ptr) (bit (1)) ;; message-pointer comments recipients ack (return fixed bin (35.)))) ;; code (declare (defpl1 e_mail_pl1_$emacs_get_address_list "" (char (*)) (return ptr) (return ptr) ;; address list address-pointer list of address errors (return fixed bin (35.)))) ;; code (declare (defpl1 e_mail_pl1_$emacs_parse_message_text "" (char (*)) (return ptr) (return ptr) ;; message message-pointer parse error pointer (return fixed bin(35.)))) ;; code (declare (defpl1 e_mail_pl1_$display_parse_errors "" (ptr) (char (*)))) ;; parse error list ptr message text (declare (defpl1 e_mail_pl1_$emacs_deliver_message "" (ptr) (bit (1)) (return fixed bin(35.)))) ;; message-ptr request-ack code (declare (defpl1 e_mail_pl1_$emacs_create_message "" (char (*)) (return ptr) (return fixed bin(35.)))) ;; subject message-ptr code (declare (defpl1 e_mail_pl1_$emacs_expand_svbx_pathname "" (char (*)) (return char (168.)) (return char (32.)) (return fixed bin (35.)))) ;; pathname dirname entryname code (declare (defpl1 e_mail_pl1_$emacs_format_header "" (ptr) (fixed bin) (ptr) ;; message ptr line length temp seg/bmstring (return fixed bin(35.))))) ;; code (declare (defpl1 e_mail_pl1_$free_parse_text_error_list "" (ptr))) ;; parse_error_list ptr (declare (defpl1 mail_system_$free_message "" (ptr) (return fixed bin(35.)))) (declare (defpl1 mail_system_$free_address_list "" (ptr) (return fixed bin (35.)))) (declare (defpl1 mail_system_$add_reply_reference "" (update ptr) (ptr) (fixed bin) ;; new-message-ptr original-message-ptr position (return fixed bin(35.)))) ;; code (defcom send-mail (send-mail-beargumented (trim-minibuffer-response "Mail subject: "))) ;;; Here we make life easy for any applications which may wish to call us ;;; We can be called with a subject string, addresses string, and even some ;;; initial text (any or which may be omited and default to ""). ;;; The application can ignore mail_system_ totally ... we do all of the work (defun send-mail-beargumented (&optional (subject "") (additional-to-recipients "") (initial-text "")) (let ((result (e_mail_pl1_$emacs_create_message subject))) (let ((msg (car result)) (code (cadr result))) (if (not (= code 0)) (display-com-error code "While creating new message.") else (setq rmail-original-buffer nil) ;go back to most recent buffer when done (find-buffer-in-window (make_atom (rtrim (catenate "Mail about " subject)))) (send-mail-beargumented-1 msg additional-to-recipients initial-text))))) (defun send-mail-beargumented-1 (message-ptr additional-to-recipients initial-text) (if (not rmail-initialized) (mail-init)) (if (empty-buffer-p current-buffer) (let ((code (e_mail_pl1_$emacs_format_header message-ptr screenlinelen mail-header-buffer)) (free-code (mail_system_$free_message message-ptr))) (if (not (= code 0)) (display-com-error code "While formating header.") else (if (not (= free-code 0)) (display-com-error-noabort "While freeing message.")) (insert-string (e_lap_$make-dat-ol-black-magic-string mail-header-buffer)))) (mapc '(lambda (x)(set-key (car x)(cadr x))) '((^X^S send-the-mail) (ESC-^B backward-mail-field) (ESC-^F forward-mail-field) (ESC-^D delete-mail-field) (ESC-CR continue-mail-field) (^XF mail-from) (^XT mail-to) (^XA mail-append) (^X^A mail-toggle-ack) (^ZB mail-bcc) ; everything else is taken (^XC mail-cc) (^XJ mail-subject) (^XL rmail-logger-append) (^XP rmail-logger-prepend) (^XY mail-reply-to))) (setq current-buffer-mode 'Mail) (fill-mode) (setq fill-column 72.) ;protocol (register-local-var 'mail-mark) (register-local-var 'mail-request-ack) (setq mail-request-ack rmail-request-acknowledgement) (if mail-request-ack (assert-minor-mode 'Ack) else (negate-minor-mode 'Ack)) ;phx17317 (mail-clean-up-from) (go-to-beginning-of-buffer) (if (not (forward-search (catenate NL "To:"))) (go-to-end-of-buffer) (mail-init-header-field "To:" additional-to-recipients) (setq mail-mark (set-mark)) (mail-to) else (go-to-end-of-buffer) (setq mail-mark (set-mark))) (if mail-mode-hook (funcall mail-mode-hook)) (insert-string initial-text) else (mail-append))) (defun mail-clean-up-from () ; let's be pretty (save-excursion (go-to-beginning-of-buffer) (if (forward-search "From:") (delete-white-sides) (insert-string TAB)))) (defun mail-init () ;Once per loading (setq mail-header-buffer (e$get_temporary_seg)) (set-emacs-epilogue-handler '(rmail-cleanup) nil) (setq rmail-initialized t)) (defun mail-find-first-blank-line () (go-to-beginning-of-buffer) (do-forever (if (or (lastlinep)(line-is-blank))(stop-doing)) (next-line))) (defcom continue-mail-field (go-to-end-of-line) (delete-white-sides) (if (not (back-at ",")) (insert-char ",")) (insert-char NL) (insert-string " ") (save-excursion (mail-find-header-end) (backward-char) (set-mark-here mail-mark))) (defcom mail-to (mail-header-field-finder "To:")) (defcom mail-reply-to (mail-header-field-finder "Reply-To:")) (defcom mail-from (mail-header-field-finder "From:")) (defcom mail-cc (mail-header-field-finder "cc:")) (defcom mail-bcc (mail-header-field-finder "bcc:")) (defcom mail-subject (mail-header-field-finder "Subject:")) (defun mail-header-field-finder (arg &aux uc-arg arg-len) (setq uc-arg (uppercase arg) arg-len (stringlength arg)) (go-to-beginning-of-buffer) (do-forever (cond ((or (looking-at arg) (samepnamep uc-arg ;case insensitive header match (uppercase (substr (curline-as-string) 1 arg-len)))) (go-to-end-of-line) (stop-doing)) ((or (lastlinep) (point>markp mail-mark)) (mail-header-add-new-line arg) (stop-doing)) (t (next-line))))) (defun look-for-mail-header-field (arg) (go-to-beginning-of-buffer) (do-forever (if (looking-at arg) (if (point>markp mail-mark)(return nil) else (forward-search arg)(return t))) (if (lastlinep)(return nil)) (next-line))) (defun mail-header-add-new-line (arg) (mail-find-header-end) (insert-string arg) (insert-string TAB) (insert-string NL) (set-mark-here mail-mark) (backward-char)) (defun mail-init-header-field (key value) (insert-string key) (insert-string TAB) (insert-string value) (new-line)) (defcom mail-append (mail-find-header-end) (if (lastlinep) (new-line) else (go-to-end-of-buffer))) (defun mail-find-header-end () (go-to-beginning-of-buffer) (if (lastlinep) nil ;close enuf else (do-forever (if (lastlinep) (return nil)) ;global punt (if (line-is-blank)(next-line) else (stop-doing))) (do-forever ;At header start? (if (forward-search-in-line ":") (do-forever (if (lastlinep) ;only headers? (stop-doing) else (next-line) (if (or (not (at-white-char)) ;Another header field (line-is-blank)) ;end of header (stop-doing)))) (if (or (lastlinep) (line-is-blank)) (stop-doing)) else (stop-doing))) ;not a header field, maybe generate error in the future? (if (not (line-is-blank)) (go-to-end-of-line) (insert-char NL)))) (defcom delete-mail-field (do-forever (if (or (back-at ":") (back-at ",") (bolp)) (stop-doing)) (backward-char)) (with-mark bof (delete-white-sides) (if (forward-search-in-line ",") (rubout-char) else (go-to-end-of-line)) (delete-white-sides) (wipe-point-mark bof) (if (eolp)(delete-white-sides) (if (back-at ",") (rubout-char) (delete-white-sides)) else (insert-string " "))) (if (< (cur-hpos) 10.) (delete-white-sides) (whitespace-to-hpos 10.))) (defcom forward-mail-field (if (eolp) (go-to-beginning-of-line)) (if (bolp) (forward-search-in-line ":") else (if (forward-search-in-line ",") else (go-to-beginning-of-line) (forward-mail-field))) (skip-over-whitespace-in-line)) (defcom backward-mail-field (if (back-at ",") (backward-char)) (if (reverse-search-in-line ",") (forward-char) else (if (back-at ":") (go-to-end-of-line) (if (save-excursion (reverse-search-in-line ",")) (backward-mail-field) else (reverse-search-in-line ":") (forward-char)) else (reverse-search-in-line ":") (forward-char))) (skip-over-whitespace-in-line)) (defcom mail-toggle-ack (setq mail-request-ack (not mail-request-ack)) (minibuffer-print (catenate "An acknowledgement will" (if mail-request-ack "" else " not") " be requested for this message.")) (if mail-request-ack (assert-minor-mode 'Ack) else (negate-minor-mode 'Ack))) ;;; Now its time to send the message (defcom send-the-mail (let ((message-text (rmail-buffer-to-string))) (let ((msg-ptr nil)) (protect (setq msg-ptr (rmail-parse-message-text message-text)) (if msg-ptr ;nil if there were parse errors (rmail-deliver-message msg-ptr)) &always (if msg-ptr (mail_system_$free_message msg-ptr)))))) (defun rmail-buffer-to-string () (save-excursion (go-to-beginning-of-buffer) (with-mark start-of-buffer (go-to-end-of-buffer) (point-mark-to-string start-of-buffer)))) ;;; Turn the current buffer into a message (puf, like magic) ;;; Note: we hack adding the reply reference here if we are a reply message, ;;; because mail_system_ can't parse In-Reply-To: fields. (grumble, grumble) (defun rmail-parse-message-text (message-text &aux error-ptr message-ptr code) ;initialized to nil (protect (let ((result (e_mail_pl1_$emacs_parse_message_text message-text))) (setq message-ptr (first result) error-ptr (second result) code (third result)) (if (not (= code 0)) (if (not (= code (error-table 'mlsys_et_ 'text_parse_failed))) (display-com-error code "While parsing message.") else (display-as-printout (rmail-display-parse-errors error-ptr message-text))) (setq message-ptr nil) ;it will be returned as the function value else (if mail-original-message-ptr (let ((result (mail_system_$add_reply_reference message-ptr mail-original-message-ptr -1))) (let ((new-message-ptr (car result)) (code (cadr result))) (if (= code 0) (setq message-ptr new-message-ptr))))))) &always (and error-ptr (not (= error-ptr null-pointer)) (e_mail_pl1_$free_parse_text_error_list error-ptr))) message-ptr) (defun rmail-display-parse-errors (error-ptr message-text) (protect (rmail-set-up-file-output) (e_mail_pl1_$display_parse_errors error-ptr message-text) &always (rmail-clean-up-file-output)) (insert-string "Message will not be delivered.") ; this will appear at the top of the buffer (new-line) (new-line)) ;;; And now we deliver the message ... (defun rmail-deliver-message (message-ptr) (let ((request-ack-flag mail-request-ack) ; make sure we are in the right buffer (code 0)) (display-as-printout (setq code (rmail-display-delivery-results message-ptr request-ack-flag))) (if (= code 0) ;happy? (rmail-restore-original-buffer)))) (defun rmail-display-delivery-results (message-ptr request-ack-flag &aux code) (protect (rmail-set-up-file-output) (setq code (e_mail_pl1_$emacs_deliver_message message-ptr (if request-ack-flag -1 else 0))) &always (rmail-clean-up-file-output)) code) (defun rmail-restore-original-buffer () (setq buffer-modified-flag nil) ;unmodify the buffer (cond ((null rmail-original-buffer) (find-buffer-in-window previous-buffer)) ((exists-buffer rmail-original-buffer) (find-buffer-in-window rmail-original-buffer)))) (defcom forward-the-mail (let ((message-ptr mail-original-message-ptr) (comment-text (rmail-buffer-to-string)) (address-ptr mail-address-ptr) (request-ack-flag mail-request-ack) (code 0)) (protect (display-as-printout (setq code (rmail-display-redistrib-results message-ptr comment-text address-ptr request-ack-flag))) (if (= code 0) (rmail-restore-original-buffer)) &always (and address-ptr (mail_system_$free_address_list address-ptr))))) (defun rmail-display-redistrib-results (message-ptr comments-text address-ptr request-ack-flag &aux code) (protect (rmail-set-up-file-output) (setq code (e_mail_pl1_$emacs_redistribute_message message-ptr (if comments-text comments-text else "") address-ptr (if request-ack-flag -1 else 0 ))) (if (not (= code 0)) (display-com-error code "Forwarding mail.")) &always (rmail-clean-up-file-output)) code) ;;; Emacs merry mailman ;;; BSG 12/16-17/78, 3/17-18/79 ;;; Dedicated to Ray Heatherton of old. ;;; Here starts Emacs read mail (RMAIL) (declare (special error-table fpathname rmail-message-buffer FF rmail-msgx rmail-mailbox-path read-only-flag rmail-seen rmail-deleteq rmail-msgcount last-input-char rmail-original-yank-indent mail-original-message rmail-open-state rmail-buffer-to-go-back-to rmail-mailbox-ptr rmail-send-acknowledgement rmail-reply-include-authors rmail-reply-include-recipients rmail-reply-include-self rmail-header-format start-up/.rmail)) (defvar rmail-mode-hook nil) ;;; (register-option 'rmail-original-yank-indent 4) ;moved to e_option_defaults_ ;;; (register-option 'rmail-send-acknowledgement t) ;moved to e_option_defaults_ ;;; (register-option 'rmail-request-acknowledgement nil) ;moved to e_option_defaults_ ;;; (register-option 'rmail-reply-include-authors t) ;moved to e_option_defaults_ ;;; (register-option 'rmail-reply-include-recipients nil) ;moved to e_option_defaults_ ;;; (register-option 'rmail-reply-include-self nil) ;moved to e_option_defaults_ ;;; (register-option 'rmail-header-format 'default-formatting-mode) ;moved to e_option_defaults_ ;;; the MCR boards felt this was too complicated, so we won't make them ;;; offical options --- JR 09/02/83 (defvar envelope-format-var nil) (defvar header-format-var nil) (defvar redistributions-list-format-var nil) ;;; defpl1's for the read mail side (declare (defpl1 e_mail_pl1_$emacs_mailbox_open "" (char (*)) (char (*)) (return ptr) (return bit (1)) (return fixed bin) ;; directory entry mailbox ptr salvaged count (return fixed bin (35.)))) ;; code (declare (defpl1 e_mail_pl1_$emacs_read_message "" (ptr) (ptr) ;; message ptr temp seg ptr (fixed bin) (bit (1)) ;; line length acknowledge (char (*)) (char (*)) (char (*)) ;; envelope-format header-format redistributions-format (return fixed bin (21.)) (return bit (1)) ;; number of lines in body seen switch (return fixed bin (35.)))) ;; code (declare (defpl1 e_mail_pl1_$emacs_get_message_ptr "" (ptr) (fixed bin) (return ptr) ;; mailbox-ptr message-number message-ptr (return fixed bin(35.))))) ;; code (declare (defpl1 e_mail_pl1_$get_user_default_mbx_address "" (return ptr))) (declare (defpl1 e_mail_pl1_$emacs_mailbox_close "" (ptr) (return fixed bin))) (declare (defpl1 e_mail_pl1_$emacs_create_reply_message "" (ptr) (bit (1)) (bit (1)) (bit (1)) ;; orig msg include-authors include-recip include self (return ptr) (return fixed bin(35.)))) ;; new msg code (declare (defpl1 mail_system_$read_new_messages "" (update ptr) (return fixed bin) (return fixed bin) ;; mailbox-ptr new-messages new-regular messages (return fixed bin) (return fixed bin(35.)))) ;; new-interactive-messages code (declare (defpl1 mail_system_$get_address_pathname "" (ptr) (return char (168.)) (return char (32.)) ;; address directory entryname (return char (32.)) (return fixed bin (35.)))) ;; componentname code (declare (defpl1 mail_system_$mark_message_for_deletion "" (ptr) (return fixed bin(35.)))) ;; message ptr code (declare (defpl1 mail_system_$unmark_message_for_deletion "" (ptr) (return fixed bin(35.)))) ;; message ptr code (declare (defpl1 mail_system_$save_message "" (ptr) (char (*)) (char (*)) (bit (1)) ;; message ptr dir name entry name create flag (return fixed bin(35.)))) ;; code (surprise, surprise) (declare (defpl1 mlsys_utils_$parse_address_text "" (char (*)) (return ptr) (return fixed bin (35.)))) ;; text-address mlsys-address code (declare (defpl1 mlsys_utils_$parse_mailbox_text "" (char (*)) (return char (168)) (return char (32)) ;; mbx-name mbx-path-dir mbx-path-entry (return fixed bin (35.)))) ;; code (declare (defpl1 mlsys_utils_$print_message_summary_header "" (fixed bin) (ptr) (return fixed bin (35.)))) ;; line length output iocb code (declare (defpl1 mlsys_utils_$print_message_summary "" (ptr) (fixed bin) (bit (1) aligned) ;; message ptr message number current message flag (fixed bin) (ptr) (return fixed bin (35.)))) ;; line length output iocb code (declare (defpl1 mail_system_$free_address "" (ptr) (return fixed bin (35.)))) ;; address code (declare (defpl1 expand_pathname_ "" (char (*)) (return char(168.)) (return char(32.)) (return fixed bin(35.)))) (declare (defpl1 pathname_ "" (char (*)) (char (*)) (return char (168)))) (defun rmail-init () (setq rmail-open-state nil) ;Signifies initted (if (not rmail-initialized) (mail-init)) (setq rmail-message-buffer nil)) (defun rmail-cleanup () ;In case he leaves without closing (if rmail-open-state (e_mail_pl1_$emacs_mailbox_close rmail-mailbox-ptr))) (defcom rmail &numarg &pass (if (not (boundp 'rmail-open-state))(rmail-init)) (if rmail-open-state (go-to-buffer 'Incoming/ mail) else (rmail-open-mbx (if numarg (rmail-get-address-pathname-from-user) else (rmail-get-address-pathname (rmail-get-default-address)))) (setq rmail-message-buffer (e$get_temporary_seg)) (setq rmail-buffer-to-go-back-to current-buffer) (go-to-or-create-buffer 'Incoming/ mail) (setq current-buffer-mode 'RMAIL) (setq fpathname rmail-mailbox-path) (setq buffer-modified-flag t rmail-open-state t) (minibuffer-clear) (mapc '(lambda (x)(set-key (car x)(cadr x))) '((/0 rmail-argument) (/1 rmail-argument) (/2 rmail-argument) (/3 rmail-argument) (/4 rmail-argument) (/5 rmail-argument) (/6 rmail-argument) (/7 rmail-argument) (/8 rmail-argument) (/9 rmail-argument) (/- rmail-minus) (? rmail-help) (m send-mail-from-rmail) (c rmail-copy) (D rmail-queue-delete-backward) (d rmail-queue-delete-forward) (j rmail-go-command) (g rmail-go-command) (l rmail-go-last-msg) (n rmail-go-forward) (p rmail-go-backward) (x rmail-toggle-seen) (q rmail-quit) (^X^Q rmail-quit) (r rmail-reply) (f rmail-forward) (s rmail-summarize) (u rmail-undelete) (^XL rmail-logger-append) (^XP rmail-logger-prepend))) (rmail-unbind-word-commands-kludge) (without-modifying (destroy-buffer-contents)) (setq read-only-flag t buffer-modified-flag nil) (if (= rmail-msgcount 0) (rmail-quit) (display-error "No messages in " rmail-mailbox-path)) (setq rmail-msgx 1 rmail-deleteq nil) (if (boundp 'start-up/.rmail) (mapc 'eval start-up/.rmail)) (if (and (boundp 'rmail-mode-hook) rmail-mode-hook) (funcall rmail-mode-hook)) (rmail-display-current-msg) (select-buffer-window current-buffer 'cursize)) (minibuffer-print "Type ""?"" for a list of rmail commands.") &doc "$$$ is an emacs interface into the mail system. By default, mail is read from your personal default mailbox. With a positive numeric argument (e.g. ^U), $$$ prompts for the ""mailbox name"". Commands available to $$$ are: $$rmail-help$ Displays this information. $$rmail-go-forward$ Moves on to the next message. $$rmail-go-backward$ Moves back to the previous message. $$rmail-go-last-msg$ Moves to the last message in your mailbox. $$rmail-go-command$ Moves to the message number specified by the numeric argument. $$rmail-queue-delete-forward$ Queue the current message for deletion - move to next message. $$rmail-queue-delete-backward$ Same as d, but moves backward. $$rmail-undelete$ Brings back the last (stacked) deleted message. $$rmail-copy$ Copies the message to some other mailbox. $$rmail-quit$ Quits out of rmail returning to the original buffer. $$rmail-summarize$ Summarizes (in a local display) all undeleted messages. $$rmail-toggle-seen$ Toggles the ""Seen"" switch of the current message. $$rmail-logger-append$ Log the message to an ASCII file, placing it at the end of the file. $$rmail-logger-prepend$ Same as ^XL, but ""prepends"" to the front. $$rmail-forward$ Forward the current message to a list of addresses. $$rmail-reply$ Formats a MAIL mode buffer to reply to the current message. $$send-mail-from-rmail$ Sends mail that is not necessarily a reply (see $$rmail-reply$). ") (defcom rmail-help &prologue rmail-check-if-in-rmail &na (&reject) (if (samepnamep current-buffer-mode 'RMAIL) (minibuffer-remark "Please wait...") (describe 'rmail) (minibuffer-clear) else (display-error "Not in RMAIL mode"))) (defun rmail-unbind-word-commands-kludge () ;they forced me (rmail-unbind-if-bound '(1 125 nil) 'upper-case-word) ;esc-U (rmail-unbind-if-bound '(1 114 nil) 'lower-case-word) ;esc-L (rmail-unbind-if-bound '(1 103 nil) 'capitalize-initial-word)) ;esc-C (defun rmail-unbind-if-bound (key-list function) ;unbind key-list if bound to function (if (eq (get-key-binding key-list) function) (set-key (get-key-name key-list) 'undefined-command))) (defun rmail-open-mbx (mbxpath) ;mbxpath is (dir . entry) (let ((result (e_mail_pl1_$emacs_mailbox_open (car mbxpath) (cdr mbxpath)))) (let ((mailbox-pointer (car result)) (salvaged (cadr result)) (msgcount (caddr result)) (code (cadddr result))) (if (not (= 0 code)) (display-com-error code (rtrim (pathname_ (car mbxpath) (cdr mbxpath))))) (if (not (= 0 salvaged)) (minibuffer-print "Mailbox has been salvaged.")) (setq rmail-mailbox-path (rtrim (pathname_ (car mbxpath) (cdr mbxpath)))) (setq rmail-msgcount msgcount) (setq rmail-mailbox-ptr mailbox-pointer) 1))) ;;; This gets a string from the user turns it into a pathname ;;; using the mail system address to parse it if needed (defun rmail-get-address-pathname-from-user () (let ((answer (trim-minibuf-response "Mailbox: " NL))) (cond ((nullstringp answer) (display-error "No mailbox name given.")) ((and (= 1 (index answer "{")) ; {thing} (samepnamep (substr answer (stringlength answer)) "}")) (let ((result (mlsys_utils_$parse_address_text answer)) (address nil) (code 0) (path "")) (protect (setq address (car result) code (cadr result)) (if (not (= code 0)) (display-com-error code "Getting mail address for " answer) else (setq path (rmail-get-address-pathname address)) (let ((entry (rtrim (cdr path)))) (if (not (samepnamep ".mbx" ;catch .forum/.mls (substr entry (- (stringlength entry) 3)))) (display-error "The specified address does not identify a mailbox. " answer)))) &always (and address (mail_system_$free_address address))) path)) (t (let ((result (mlsys_utils_$parse_mailbox_text answer))) (let ((code (third result))) (if (not (zerop code)) (display-com-error code answer)) (rplacd result (second result)))))))) ;return (dir . entry) (defun rmail-get-default-address () (e_mail_pl1_$get_user_default_mbx_address)) (defun rmail-get-address-pathname (address) (let ((result (mail_system_$get_address_pathname address))) (let ((dir (first result)) (entry (second result)) (code (fourth result))) (cond ((not (= code 0)) (display-com-error code "Getting pathname of mailbox address")) (t (cons dir entry)))))) ;;; Get an address list from the user, parse and verify the addressees into ;;; an address-list structure to be used by the mail_system. Note that ;;; addressees must be separated by ","s as that is what it appears the ;;; mail_system wants. (defun rmail-get-address-list-from-user (&aux error-ptr address-ptr code) (let ((answer (trim-minibuf-response "Forward to: "))) (cond ((nullstringp answer) (display-error "No addresses given.") nil) (t (protect (let ((result (e_mail_pl1_$emacs_get_address_list answer))) (setq address-ptr (first result) error-ptr (second result) code (third result)) (if (not (= code 0)) (if (not (= code (error-table 'mlsys_et_ 'text_parse_failed))) (display-com-error code "While parsing address list.") else (display-as-printout (rmail-display-parse-errors error-ptr answer))) (setq address-ptr nil))) &always (and error-ptr (not (= error-ptr null-pointer)) (e_mail_pl1_$free_parse_text_error_list error-ptr)) &failure (and address-ptr (mail_system_$free_address_list address-ptr)))))) address-ptr) ;;; Display the current (i.e. rmail-msgx) message. (defun rmail-display-current-msg () (if (not (eq current-buffer 'Incoming/ mail)) (display-error "Error: not in RMAIL")) (if (> rmail-msgx rmail-msgcount) (display-error-noabort "No next msg.")) (setq fpathname rmail-mailbox-path) (without-modifying (destroy-buffer-contents) (let ((msg (rmail-read-message rmail-msgx))) ;;; Set the seen switch as we are now looking at it, so it really is seen (rmail-set-seen t) ;;; Display the message size and the message (insert-string (catenate "(" (decimal-rep rmail-msgx) ") -- " (decimal-rep (car msg)) " line" (if (= (car msg) 1) "" else "s"))) (new-line) (new-line) (insert-string (cdr msg)) (go-to-beginning-of-buffer)))) ;;; This calls the mail system to actually format the message and ;;; returns (number of lines in text; a black magic string containing the ;;; entire message) (defun rmail-read-message (message-number) (let ((message-ptr (rmail-get-message-ptr rmail-mailbox-ptr message-number))) (let ((result (e_mail_pl1_$emacs_read_message message-ptr rmail-message-buffer screenlinelen (if rmail-send-acknowledgement -1 else 0) ;;; if the user has given values to various formatting option variable, ;;; then we use them, otherwise we use the documented rmail-header-format ;;; option (or envelope-format-var (cond ((eq rmail-header-format 'brief-formatting-mode) 'none-formatting-mode) (t rmail-header-format))) (or header-format-var rmail-header-format) (or redistributions-list-format-var rmail-header-format)))) (let ((lines-in-body (first result)) ;MF (code (third result))) ;MF (setq rmail-seen (if (= (second result) 0) nil else t)) (cond ((= code -1) ; e_mail_pl1_ special case (display-com-error 0 "envelope-format (rmail-header-format) is invalid.")) ((= code -2) (display-com-error 0 "rmail-header-format is invalid.")) ((= code -3) (display-com-error 0 "redistributions-list-format (rmail-header-format) is invalid.")) ((not (= code 0)) (display-com-error-noabort code "Reading message " (decimal-rep message-number))) (t (cons lines-in-body (e_lap_$make-dat-ol-black-magic-string rmail-message-buffer)))))))) ;;; Given a mailbox and a message number get a pointer to a mail system ;;; message structure. e_mail_pl1_ will read the message if it hasn't ;;; already done so. (defun rmail-get-message-ptr (mailbox-ptr message-number) (let ((result (e_mail_pl1_$emacs_get_message_ptr mailbox-ptr message-number))) (let ((message-ptr (car result)) (code (cadr result))) (if (not (= code 0)) (display-com-error code "While getting message " (decimal-rep (message-number)) ".")) message-ptr))) (defcom rmail-quit &prologue rmail-check-if-in-rmail-buffer (let ((message-to-goto (1+ rmail-msgcount))) (if (and (rmail-check-for-new-messages) ;new messages and (= rmail-commands-since-new-mail 0)) ;no new commands (if (yesp "Do you still want to quit?") (rmail-quit-1) else (rmail-go message-to-goto 'forward)) else (rmail-quit-1)))) (defun rmail-quit-1 () (if rmail-message-buffer (e$release_temporary_seg rmail-message-buffer)) (let ((code (e_mail_pl1_$emacs_mailbox_close rmail-mailbox-ptr))) (if (not (= code 0)) (display-com-error code "closing" rmail-mailbox-path))) (set-buffer-self-destruct current-buffer) (rmail-echo "") (setq rmail-open-state nil) (go-to-or-create-buffer rmail-buffer-to-go-back-to)) (defun rmail-check-if-in-rmail-buffer () ;check rmail buffer (cond ((eq current-buffer-mode 'RMAIL) t) (t (display-error "Error: not in RMAIL") nil))) (defun rmail-check-if-in-rmail () (cond ((rmail-check-if-in-rmail-buffer) ;check rmail buffer (setq rmail-commands-since-new-mail ;increment command count (+ rmail-commands-since-new-mail 1)) (rmail-check-for-new-messages)))) ;check for new mail (defun rmail-check-for-new-messages () (let ((result (mail_system_$read_new_messages rmail-mailbox-ptr))) (setq rmail-mailbox-ptr (car result)) (let ((number-of-new-messages (cadr result)) (code 0)) ; (code (cadddr (cdr result)))) ; this won't run compiled (setq code (cadddr (cdr result))) ; but this appears to work (if (and (not (= code 0)) (not (= code (error-table 'mlsys_et_ 'no_more_messages)))) (display-com-error-noabort code "Trying to determine if new messages had arrived.") nil else (if (= number-of-new-messages 0) nil else (setq rmail-msgcount (+ rmail-msgcount number-of-new-messages)) (setq rmail-commands-since-new-mail 0) ;reset count (if (= 1 number-of-new-messages) (minibuffer-print "One new message has arrived.") else (minibuffer-print (decimal-rep number-of-new-messages) " new messages have arrived.")) t))))) (defcom rmail-argument &prologue rmail-check-if-in-rmail &numeric-argument (&pass) (rmail-echo last-input-char) (let ((digit (- (CtoI last-input-char) (CtoI "0")))) (if (null numarg) (setq numarg digit) else (setq numarg (if (< numarg 0) (- (* numarg 10.) digit) else (+ (* numarg 10.) digit))))) (process-char (get-char))) (defcom rmail-minus &prologue rmail-check-if-in-rmail (rmail-echo last-input-char) (let ((c (get-char))) (if (or (< c (CtoI "0")) (> c (CtoI "9"))) (setq numarg -1) (process-char c) else (setq numarg (- (CtoI "0") c)) (rmail-echo (ItoC c)) (process-char (get-char))))) (defcom rmail-go-forward () &prologue rmail-check-if-in-rmail &numeric-argument (&pass) &negative-function rmail-go-backward (rmail-echo last-input-char) (rmail-go (+ rmail-msgx (or numarg 1)) 'forward)) (defcom rmail-go-backward &prologue rmail-check-if-in-rmail &numeric-argument (&pass) &negative-function rmail-go-forward (rmail-echo last-input-char) (rmail-go (- rmail-msgx (or numarg 1)) 'backward)) (defcom rmail-go-last-msg &prologue rmail-check-if-in-rmail (rmail-check-for-new-messages) (rmail-echo 'l) (rmail-go rmail-msgcount 'backward)) (defun rmail-not-deleted-message (message-number) (not (memq message-number rmail-deleteq))) (defun rmail-queue-deletion (message-index) (if (rmail-not-deleted-message message-index) (let ((message-ptr (rmail-get-message-ptr rmail-mailbox-ptr message-index))) (let ((code (mail_system_$mark_message_for_deletion message-ptr))) (if (not (= 0 code)) (display-com-error code "deleting message " (decimal-rep message-index)) else (setq rmail-deleteq (cons message-index rmail-deleteq))))) else (display-error "Message " (decimal-rep message-index) "has already been deleted."))) (defcom rmail-queue-delete-forward &prologue rmail-check-if-in-rmail (rmail-echo 'd) (rmail-queue-deletion rmail-msgx) (cond ((let ((mno (rmail-find-message-forward (1+ rmail-msgx)))) (if mno (rmail-go mno 'forward) t else nil))) ((let ((mno (rmail-find-message-backward (1- rmail-msgx)))) (if mno (rmail-go mno 'backward) t else nil))) (t (rmail-delete-desperator)))) (defcom rmail-queue-delete-backward &prologue rmail-check-if-in-rmail (rmail-echo 'D) (rmail-queue-deletion rmail-msgx) (cond ((let ((mno (rmail-find-message-backward (1- rmail-msgx)))) (if mno (rmail-go mno 'backward) t else nil))) ((let ((mno (rmail-find-message-forward (1+ rmail-msgx)))) (if mno (rmail-go mno 'forward) t else nil))) (t (rmail-delete-desperator)))) (defun rmail-delete-desperator () (cond ((yesp "All messages deleted. Quit rmail?") (rmail-quit)) (t (minibuffer-print "Undeleting this message.") (rmail-undelete)))) (defcom rmail-undelete &prologue rmail-check-if-in-rmail (rmail-echo 'u) (if rmail-deleteq (let ((last-deleted-message (car rmail-deleteq))) (let ((message-ptr (rmail-get-message-ptr rmail-mailbox-ptr last-deleted-message))) (let ((code (mail_system_$unmark_message_for_deletion message-ptr))) (if (not (= code 0)) (display-com-error code "Un-deleting message " (decimal-rep last-deleted-message)) else (setq rmail-deleteq (cdr rmail-deleteq)) (rmail-go last-deleted-message 'forward))))) else (display-error-noabort "No pending deletions.") (ring-tty-bell))) ;;; Toggle the seen switch on the current message, update the minor mode to ;;; reflect the new status. (defcom rmail-toggle-seen () &prologue rmail-check-if-in-rmail (rmail-echo 'x) (rmail-set-seen (not rmail-seen))) (defun rmail-set-seen (mode) (let ((code (mail_system_$set_message_switch (rmail-get-message-ptr rmail-mailbox-ptr rmail-msgx) "SEEN" (if mode -1 else 0)))) (cond ((= code 0) (setq rmail-seen mode) (if rmail-seen (assert-minor-mode 'Seen) else (negate-minor-mode 'Seen))) (t (display-com-error code "While setting seen switch."))))) (declare (special tty-no-upmotionp)) (defun rmail-echo (x) (if (not tty-no-upmotionp) (minibuffer-print-noclear x))) (defun rmail-go (msgno direction) (if (> msgno rmail-msgcount)(rmail-check-for-new-messages)) (cond ((and (> msgno rmail-msgcount)(eq direction 'forward)) (display-error "No more messages forward.")) ((or (< msgno 1)(> msgno rmail-msgcount)) (display-error "Invalid message number: " (decimal-rep msgno))) ((rmail-not-deleted-message msgno) (setq rmail-msgx msgno) (rmail-display-current-msg)) ((eq direction 'forward) (let ((fno (rmail-find-message-forward msgno))) (if fno (rmail-go fno 'forward) else (display-error "No more messages forward.")))) (t (let ((fno (rmail-find-message-backward msgno))) (if fno (rmail-go fno 'backward) else (display-error "No more messages backward.")))))) (defun rmail-find-message-forward (msgno) (do ((tentative msgno (1+ tentative)) (checkedflag)) ((> tentative rmail-msgcount) nil) (if (rmail-not-deleted-message tentative) (return tentative)) (if (and (= tentative rmail-msgcount)(not checkedflag)) (setq checkedflag t) (rmail-check-for-new-messages)))) (defun rmail-find-message-backward (msgno) (do ((tentative msgno (1- tentative))) ((< tentative 1) nil) (if (rmail-not-deleted-message tentative) (return tentative)))) (defcom rmail-go-command &prologue rmail-check-if-in-rmail &numarg &pass (let ((here rmail-msgx)) (if numarg (rmail-go numarg 'forward)) (if (not (= here rmail-msgx)) (rmail-echo (catenate "(" (decimal-rep rmail-msgx) ")"))))) (defcom rmail-summarize &prologue rmail-check-if-in-rmail (rmail-check-for-new-messages) (display-as-printout (rmail-create-summary-buffer))) (defun rmail-create-summary-buffer () (protect (rmail-set-up-file-output) (rmail-get-summary-header) (do message-number 1 (1+ message-number) (> message-number rmail-msgcount) (if (rmail-not-deleted-message message-number) (rmail-summarize-one message-number))) &always (rmail-clean-up-file-output))) (defun rmail-get-summary-header () (let ((code (mlsys_utils_$print_message_summary_header screenlinelen null-pointer))) (if (not (= code 0)) (go-to-buffer 'Incoming/ mail) (rmail-clean-up-file-output) (display-com-error code "While getting message summary header.")))) (defun rmail-summarize-one (message-number) (let ((message-ptr (rmail-get-message-ptr rmail-mailbox-ptr message-number)) (current-msg-flag 0)) ;"0"b (if (= rmail-msgx message-number) (setq current-msg-flag -1));"1"b (let ((code (mlsys_utils_$print_message_summary message-ptr message-number current-msg-flag screenlinelen null-pointer))) (if (not (= code 0)) (rmail-clean-up-file-output) (go-to-buffer 'Incoming/ mail) (display-com-error code "While getting summary for message" (decimal-rep message-number)))))) ; Maybe there is too much internal knowledge here, and this should ; be done some other way ; delcare's for file-output hacking (declare (special pdir-temp-ename pdir-temp-pathname)) (declare (*lexpr ncline e_pl1_$get_iocb hcs_$truncate_file hcs_$set_bc)) (declare (defpl1 iox_$control "" (ptr) (char (*)) (ptr) (return fixed bin (35.)))) (defun rmail-set-up-file-output () (hcs_$set_bc process-dir pdir-temp-ename 0) (ncline 'file_output pdir-temp-pathname '-ssw 'user_output '-ssw 'error_output)) (defun rmail-clean-up-file-output () (e_cline_ "revert_output -ssw user_output -ssw error_output") (let ((fpathname nil)) (read-in-file pdir-temp-pathname)) (hcs_$truncate_file process-dir pdir-temp-ename 0) (iox_$control (e_pl1_$get_iocb) "reset_more" null-pointer)) ;;; Reply (defcom rmail-reply &prologue rmail-check-if-in-rmail &numarg &pass (rmail-echo 'r) (setq rmail-original-buffer current-buffer) (let ((original-message-text (rmail-collect-orig)) (include-authors (if (or rmail-reply-include-authors numarg) -1 else 0)) (include-recipients (if (or rmail-reply-include-recipients numarg) -1 else 0)) (include-self (if rmail-reply-include-self -1 else 0)) (original-message-ptr (rmail-get-message-ptr rmail-mailbox-ptr rmail-msgx))) (let ((result (e_mail_pl1_$emacs_create_reply_message original-message-ptr include-authors include-recipients include-self))) (let ((new-message-ptr (car result)) (code (cadr result))) (if (not (= code 0)) (display-com-error code "While creating reply message.")) (find-buffer-in-window (make_atom (catenate "Reply to message " (decimal-rep rmail-msgx))));;; ugh, ugh, ugh (without-saving (destroy-buffer-contents)) (send-mail-beargumented-1 new-message-ptr "" "") (mail-append) (setq current-buffer-mode 'RMAIL/ reply) (rmail-prepare-response-environment original-message-text original-message-ptr))))) (defun rmail-collect-orig () (save-excursion (go-to-beginning-of-buffer) (next-line) (with-mark start-of-buffer (go-to-end-of-buffer) (point-mark-to-string start-of-buffer)))) ;;; 10/15/80 (defcom send-mail-from-rmail &prologue rmail-check-if-in-rmail (let ((msg (rmail-collect-orig))) (execute-command 'send-mail nil nil) (rmail-prepare-response-environment msg nil))) ;;; We must keep track of the original message and add the reply reference ;;; ourselves because mail_system_ can't hack parsing In-Reply-To: fields ;;; (grumble, grumble) (defun rmail-prepare-response-environment (original-msg-text original-msg-ptr) (register-local-var 'mail-original-message) (register-local-var 'rmail-original-buffer) ; buffer to return to if successful (setq mail-original-message original-msg-text) (setq rmail-original-buffer 'Incoming/ mail) (if original-msg-ptr ; non-nil implies we are a reply message (register-local-var 'mail-original-message-ptr) (setq mail-original-message-ptr original-msg-ptr)) (set-key 'ESC-^Y 'rmail-yank-mail) (set-key '^X^Q 'return-to-rmail)) (defcom return-to-rmail (minibuffer-clear) (find-buffer-in-window 'Incoming/ mail)) (defcom rmail-yank-mail &numeric-argument (&reject) (set-the-mark) (insert-string mail-original-message) (let ((numarg rmail-original-yank-indent)) (indent-rigidly)) (if (not (back-at NL))(new-line))) ;;; 02/07/89 ;;; Forward the current piece of mail to a list of addresses. A numeric ;;; argument allows the user to add redistribution comments to the mail ;;; by creating a comments buffer. (defcom rmail-forward &prologue rmail-check-if-in-rmail &numarg &pass (rmail-echo 'f) (setq rmail-original-buffer current-buffer) (let ((original-message-ptr (rmail-get-message-ptr rmail-mailbox-ptr rmail-msgx)) (address-ptr nil)) (protect (cond ((setq address-ptr (rmail-get-address-list-from-user)) (if numarg (find-buffer-in-window (make_atom (catenate "Forwarding comments for message " (decimal-rep rmail-msgx)))) (rmail-prepare-comment-environment original-message-ptr address-ptr) else (display-as-printout (rmail-display-redistrib-results original-message-ptr nil address-ptr mail-request-ack)) (and address-ptr (mail_system_$free_address_list address-ptr))))) &failure (and address-ptr (mail_system_$free_address_list address-ptr))))) ;;; Prepare the current buffer as a comment buffer for sending redistribution ;;; comments (defun rmail-prepare-comment-environment (original-msg-ptr address-ptr) ;;; Local variables used (register-local-var 'rmail-original-buffer) ; return buffer (register-local-var 'mail-original-message-ptr); mail to forward (register-local-var 'mail-address-ptr) ; destination addresses (register-local-var 'mail-request-ack) ; if an ack is required (setq rmail-original-buffer 'Incoming/ mail) (setq mail-original-message-ptr original-msg-ptr) (setq mail-address-ptr address-ptr) (setq mail-request-ack rmail-request-acknowledgement) ;;; Set up the buffer display (without-saving (destroy-buffer-contents)) (setq current-buffer-mode 'RMAIL/ comments) (if mail-request-ack (assert-minor-mode 'Ack) else (negate-minor-mode 'Ack)) ;;; Set up buffer characteristics (fill-mode) (setq fill-column 61.) ;72.-11. for indentation (set-key '^X^A 'mail-toggle-ack) (set-key '^X^Q 'return-to-rmail) (set-key '^X^S 'forward-the-mail)) ;;; ;;; RMAIL correspondence recorder ;;; (declare (special known-buflist)) (defcom rmail-logger-append &prologue rmail-check-if-in-rmail &numarg (&pass) (rmail-guts-of-logger 'append)) (defcom rmail-logger-prepend () &prologue rmail-check-if-in-rmail &numarg (&pass) (rmail-guts-of-logger 'prepend)) (defun rmail-guts-of-logger (whichway) (if (not (and (memq 'Mail/ log known-buflist) (null numarg))) (let ((new-pathname (trim-minibuf-response "RMAIL Log file: " NL))) (if (nullstringp new-pathname) (display-error "You must supply a pathname.")) (open-file new-pathname 'write) ;;; phx20937/21049 (save-excursion-buffer (go-to-or-create-buffer 'Mail/ log) (read-in-file new-pathname)))) (save-excursion (save-excursion-buffer (let ((z (curbuf-as-string))) (go-to-buffer 'Mail/ log) (if (eq whichway 'append) (go-to-end-of-buffer) else (go-to-beginning-of-buffer)) (insert-char FF) (insert-string z)) (save-same-file)))) ;;; Rmail copy request --- this is the same as read_mail's save request (defcom rmail-copy &prologue rmail-check-if-in-rmail (let ((result (e_mail_pl1_$emacs_expand_svbx_pathname (minibuf-response "Save Mailbox: " NL)))) (let ((rmail-sv-dname (car result)) (rmail-sv-ename (cadr result)) (code (caddr result))) (if (not (= code 0)) (display-com-error code "Expanding save mailbox pathname.") else (rmail-copy-1 rmail-sv-dname rmail-sv-ename 0))))) (defun rmail-copy-1 (rmail-sv-dname rmail-sv-ename create-flag) (let ((code (mail_system_$save_message (rmail-get-message-ptr rmail-mailbox-ptr rmail-msgx) rmail-sv-dname rmail-sv-ename create-flag))) (if (and (= code (error-table 'mlsys_et_ 'no_savebox)) (yesp "Save mailbox doesn't exist. Create it?")) (rmail-copy-1 rmail-sv-dname rmail-sv-ename -1) else (if (and (not (= code 0)) (not (= code (error-table 'mlsys_et_ 'savebox_created)))) (display-com-error code "Trying to save message."))))) 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