PNOTICE_extended_mail.alm 10/26/88 1539.7r w 10/26/88 1539.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., 1988" aci "C1EMFM0E0000" aci "C2EMFM0E0000" aci "C3EMFM0E0000" end  emf_et_.alm 11/05/86 1552.0r w 11/04/86 1038.6 29619 " *********************************************************** " * * " * 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-07,Herbst), approve(86-03-25,MCR7367), " audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): " Added $no_messages_selected. " END HISTORY COMMENTS " Error table for the Multics Extended Mail Facility (print_mail/read_mail/send_mail) " Created: 1978 by W. Olin Sibert and/or G. Palter " Modified: August 1983 by G. Palter for conversion of extended mail to the new mail system name emf_et_ include et_macros et emf_et_ ec address_not_found,addr^fnd, (The address was not found.) ec empty_address_list_field,emptyfld, (There are no addresses in this field.) ec empty_range,empt_rng, (No messages in the specified range.) ec expunged_message,expunged, (Specified message has already been permanently deleted from the mailbox.) ec forwarding_aborted,fwdabort, (The forwarding sub-request-loop has been aborted. The message will not be forwarded.) ec insufficient_quota_to_write,writeRQO, (There is insufficient quota to write this message into the segment.) ec insufficient_segment_size,seg2smal, (The maximum length of the segment is too small to allow this message to be written.) ec msg_spec_bad_expr,MS^expr, (Invalid expression in message specifier.) ec msg_spec_bad_keyword,MS^kwr, (Invalid keyword in message specifier.) ec msg_spec_bad_number,MS^num, (Invalid number in message specifier.) ec msg_spec_bad_oper,MS^oper, (Invalid operator in message specifier.) ec msg_spec_bad_range,MS^rng, (Invalid range in message specifier.) ec msg_spec_bad_regexp,MS^regx, (Invalid regular expression in message specifier.) ec msg_spec_invalid,badMS, (Invalid message specifier.) ec msg_spec_missing_delim,MS^delim, (Missing regular expression delimiter in message specifier.) ec msg_spec_mixed,MSmixed, (Message specifiers may not contain both ranges and regular expressions.) ec msg_spec_null,nullMS, (This is a null message specifier.) ec msg_spec_too_complex,MS>cmplx, (This message specifier is too complex.) ec no_current_message,^curmsg, (There is no current message.) ec no_first_message,^frstmsg, (There is no first message.) ec no_last_message,^lastmsg, (There is no last message.) ec no_matching_messages,nomatch, (No matching messages.) ec no_messages,no_msgs, (There are no messages.) ec no_messages_selected,nomsgsel, (No messages were selected.) ec no_next_message,^nxtMSG, (There is no next message.) ec no_previous_message,^prvMSG, (There is no previous message.) ec no_such_message,^suchmsg, (Specified message does not exist.) ec send_mail_aborted,sdmabort, (This send_mail invocation was exited without sending, saving, or writing the message.) end  emf_writing_util_.pl1 04/09/85 1556.2r w 04/08/85 1131.5 81144 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* Extended Mail Facility Utilities which support the write, append, and preface requests in read_mail and send_mail */ /* Created: by W. Olin Sibert */ /* Recoded: September 1983 by G. Palter */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ emf_writing_util_: procedure (); RETURN_FROM_OPERATION: return; /* not an entrypoint */ /* Aborts the operation in progress */ abort_operation: procedure (p_code); dcl p_code fixed binary (35) parameter; P_code = p_code; go to RETURN_FROM_OPERATION; end abort_operation; /* Parameters */ dcl P_file_ptr pointer parameter; dcl P_file_uid bit (36) aligned parameter; dcl P_code fixed binary (35) parameter; dcl P_sci_ptr pointer parameter; /* open: -> description of the subsystem invocation */ dcl P_file_dirname character (*) parameter; /* open: absolute pathname of containing directory */ dcl P_file_ename character (*) parameter; /* open: entryname of the segment */ dcl P_creation_mode fixed binary parameter; /* open: what action to take if the segment does not exist */ dcl P_text character (*) parameter; /* write: the text to be added to the segment */ dcl P_insertion_mode fixed binary parameter; /* write: how to add the text (truncate/append/preface) */ /* Local copies of parameters */ dcl file_ptr pointer; dcl file_uid bit (36) aligned; dcl insertion_mode fixed binary; dcl code fixed binary (35); /* Remaining declarations */ dcl the_file character (file_max_lth) unaligned based (file_ptr); dcl file_bit_count fixed binary (24); dcl (file_max_lth, file_lth) fixed binary (21); dcl file_max_lth_in_words fixed binary (19); dcl try_to_create bit (1); dcl file_was_created bit (1) aligned; dcl insert_position fixed binary (21); /* format: off */ dcl (emf_et_$insufficient_quota_to_write, emf_et_$insufficient_segment_size, error_table_$action_not_performed, error_table_$bad_subr_arg, error_table_$noentry, error_table_$non_matching_uid) fixed binary (35) external; /* format: on */ dcl command_query_$yes_no entry () options (variable); dcl hcs_$get_max_length_seg entry (pointer, fixed binary (19), fixed binary (35)); dcl hcs_$get_uid_seg entry (pointer, bit (36) aligned, fixed binary (35)); dcl hcs_$status_mins entry (pointer, fixed binary (2), fixed binary (24), fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl initiate_file_$create entry (character (*), character (*), bit (*), pointer, bit (1) aligned, fixed binary (24), fixed binary (35)); dcl mrl_ entry (pointer, fixed binary (21), pointer, fixed binary (21)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$print_message entry () options (variable); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl record_quota_overflow condition; dcl (addcharno, divide, length, null) builtin; %page; /* Open the file for writing: The caller specifies whether the file is to be created if not found with/without asking the user's permission and with/without informing the user of the creation */ open: entry (P_sci_ptr, P_file_dirname, P_file_ename, P_creation_mode, P_file_ptr, P_file_uid, P_code); if (P_creation_mode < DONT_CREATE_FILE) | (P_creation_mode > SILENTLY_CREATE_FILE) then call abort_operation (error_table_$bad_subr_arg); if (P_creation_mode = DONT_CREATE_FILE) | (P_creation_mode = QUERY_TO_CREATE_FILE) then do; /* Try to initiate the file without creating it if the caller doesn't want it created or wants us to ask for permission to create it. If the file doesn't exist, ask the user for permission to create it if appropriate */ call initiate_file_ (P_file_dirname, P_file_ename, RW_ACCESS, file_ptr, (0), code); if (code = error_table_$noentry) & (P_creation_mode = QUERY_TO_CREATE_FILE) then do; call command_query_$yes_no (try_to_create, 0, ssu_$get_subsystem_and_request_name (P_sci_ptr), "", "Do you wish to create the file ^a?", pathname_ (P_file_dirname, P_file_ename)); if try_to_create then /* yes: act like creation mode is to silenty create it */ go to INITIATE_OR_CREATE; else code = error_table_$action_not_performed; end; if code ^= 0 then call abort_operation (code); file_was_created = "0"b; /* needed later */ end; else do; /* Create the file (if necessary), announce the creation if appropriate, and initiate it */ INITIATE_OR_CREATE: call initiate_file_$create (P_file_dirname, P_file_ename, RW_ACCESS, file_ptr, file_was_created, (0), code) ; if file_was_created & (P_creation_mode = CREATE_AND_ANNOUNCE_FILE) then call ssu_$print_message (P_sci_ptr, 0, "Created ^a.", pathname_ (P_file_dirname, P_file_ename)); if code ^= 0 then call abort_operation (code); end; /* Finally get the file's UID and return */ call hcs_$get_uid_seg (file_ptr, file_uid, code); if code ^= 0 then do; /* sigh */ if file_was_created then call terminate_file_ (file_ptr, 0, TERM_FILE_DELETE, (0)); else call terminate_file_ (file_ptr, 0, TERM_FILE_TERM, (0)); call abort_operation (code); end; P_file_ptr = file_ptr; P_file_uid = file_uid; P_code = 0; /* success */ return; %page; /* Adds the given text to the file: The text may be added either at the beginning or end of the file. The caller may request that the file be truncated before adding the text */ write: entry (P_file_ptr, P_file_uid, P_text, P_insertion_mode, P_code); file_ptr = P_file_ptr; insertion_mode = P_insertion_mode; if (insertion_mode < TRUNCATE_FILE) | (insertion_mode > PREFACE_FILE) then call abort_operation (error_table_$bad_subr_arg); /* Verify that the caller's pointer is still valid */ call hcs_$get_uid_seg (file_ptr, file_uid, code); if code ^= 0 then call abort_operation (code); if P_file_uid ^= file_uid then call abort_operation (error_table_$non_matching_uid); /* Determine the file's length and maximum length and whether there is room to perform the requested operation */ call hcs_$status_mins (file_ptr, (0), file_bit_count, code); if code ^= 0 then call abort_operation (code); call hcs_$get_max_length_seg (file_ptr, file_max_lth_in_words, code); if code ^= 0 then call abort_operation (code); if insertion_mode = TRUNCATE_FILE then do; /* truncation is special: need to ignore above bit count */ file_bit_count = 0; call terminate_file_ (file_ptr, 0, TERM_FILE_TRUNC, code); if code ^= 0 then call abort_operation (code); end; file_lth = divide ((file_bit_count + 8), 9, 21, 0); file_max_lth = 4 * file_max_lth_in_words; if (file_lth + length (P_text)) > file_max_lth then call abort_operation (emf_et_$insufficient_segment_size); /* won't fit */ /* Add the text to the file and update its bit count: If prefacing, move the file's current content "up" to make room */ on condition (record_quota_overflow) call abort_operation (emf_et_$insufficient_quota_to_write); if (file_lth > 0) & (insertion_mode = PREFACE_FILE) then do; insert_position = 1; /* put it at the beginning of the file */ call mrl_ (file_ptr, file_lth, addcharno (file_ptr, length (P_text)), file_lth); end; else insert_position = file_lth + 1; /* put it at the end */ begin; dcl inserted_text character (length (P_text)) unaligned defined (the_file) position (insert_position); inserted_text = P_text; end; file_bit_count = 9 * (file_lth + length (P_text));/* compute new bit count */ call terminate_file_ (file_ptr, file_bit_count, TERM_FILE_BC, code); P_code = code; /* indicate success/failure of the set bit count operation */ return; %page; /* Closes the file */ close: entry (P_file_ptr, P_file_uid, P_code); file_ptr = P_file_ptr; call hcs_$get_uid_seg (file_ptr, file_uid, code); if code ^= 0 then call abort_operation (code); if P_file_uid ^= file_uid then call abort_operation (error_table_$non_matching_uid); call terminate_file_ (file_ptr, 0, TERM_FILE_TERM, code); P_file_ptr = null (); /* just give the caller one shot */ P_code = code; /* indicate success/failure of the termination */ return; %page; %include emf_writing_modes; %page; %include access_mode_values; %page; %include terminate_file; end emf_writing_util_;  print_mail.pl1 10/02/89 0908.5rew 10/02/89 0815.0 209916 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-18,Lee), approve(89-05-10,MCR8103), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx20253, phx18857, Mail 454 - modified the contents of the blast message to remove references to EXL; reformatting. END HISTORY COMMENTS */ /* format: off */ /* The Multics print_mail command: prints the messages in a mailbox and asks whether to delete each one after printing */ /* Created: September 1982 by G. Palter by merging print_mail_command_ and the appropriate code from read_mail */ /* Modified: 16 November 1979 by G. Palter to honor acknowledgements */ /* Modified: 6 August 1981 by G. Palter to set query_info.version and recognize "y" and "n" now that command_query_ recognizes them */ /* Modified: June 1983 by G. Palter to convert to new mail system interface and remove all dependencies on read_mail as a prelude to possible future bundling */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ print_mail: prm: procedure () options (variable); dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl 1 local_oo aligned like open_options; dcl 1 local_pcao aligned like parse_ca_options; dcl 1 local_fmo aligned like format_message_options; dcl sci_ptr pointer; dcl have_mailbox bit (1) aligned; /* ON => we've got a mailbox already */ dcl (mailbox_dirname, mailbox_printing_name) character (168); dcl mailbox_ename character (32); dcl formatting_mode fixed binary; dcl (acknowledge, brief, display_message_count, interactive_messages, list, mail, reverse) bit (1) aligned; dcl (first_message, last_message, current_message, direction) fixed binary; dcl processing_message bit (1) aligned; dcl disposition character (32) varying; dcl code fixed binary (35); dcl first_invocation bit (1) aligned static initial ("1"b); dcl PRINT_MAIL character (32) static options (constant) initial ("print_mail"); dcl PRINT_MAIL_VERSION character (32) static options (constant) initial ("3.0a"); dcl PRINT_MAIL_SPECIAL_MESSAGE character (256) varying static options (constant) initial (""); dcl mlsys_data_$user_default_mailbox_address pointer external; dcl iox_$user_output pointer external; /* format: off */ dcl (error_table_$inconsistent, error_table_$too_many_args, mlsys_et_$cant_be_deleted, mlsys_et_$mailbox_exists) fixed binary (35) external; /* format: on */ dcl active_fnc_err_ entry () options (variable); dcl com_err_ entry () options (variable); dcl command_query_ entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl find_condition_info_ entry (pointer, pointer, fixed binary (35)); dcl ioa_ entry () options (variable); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl mail_system_$acknowledge_message entry (pointer, fixed binary (35)); dcl mail_system_$close_mailbox entry (pointer, pointer, fixed binary (35)); dcl mail_system_$expunge_messages entry (pointer, fixed binary (35)); dcl mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35)); dcl mail_system_$mark_message_for_deletion entry (pointer, fixed binary (35)); dcl mail_system_$open_mailbox entry (character (*), character (*), pointer, character (8), pointer, fixed binary (35)); dcl mail_system_$read_message entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$unmark_message_for_deletion entry (pointer, fixed binary (35)); dcl mlsys_utils_$create_default_mailbox entry (fixed binary (35)); dcl mlsys_utils_$parse_mailbox_control_args entry (pointer, fixed binary, pointer, character (*), character (*), fixed binary (35)); dcl mlsys_utils_$print_message entry (pointer, pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_summary entry (pointer, fixed binary, bit (1) aligned, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_summary_header entry (fixed binary, pointer, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$destroy_invocation entry (pointer); dcl ssu_$print_blast entry (pointer, pointer, fixed binary, character (*) varying, fixed binary (35)); dcl ssu_$print_message entry () options (variable); dcl ssu_$record_usage entry (pointer, pointer, fixed binary (35)); dcl ssu_$set_debug_mode entry (pointer, bit (1) aligned); dcl ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35)); dcl (cleanup, program_interrupt, sub_error_) condition; dcl (addr, codeptr, index, length, null, string, substr, translate) builtin; %page; /* print_mail: prm: entry options (variable); */ sci_ptr, mailbox_ptr = null (); /* for cleanup handler */ on condition (cleanup) call release_data_structures (); call ssu_$standalone_invocation (sci_ptr, PRINT_MAIL, PRINT_MAIL_VERSION, cu_$arg_list_ptr (), abort_print_mail_command, code); if code ^= 0 then do; /* please forgive the following, but ... */ if cu_$af_return_arg (0, (null ()), (0)) = 0 then call active_fnc_err_ (code, PRINT_MAIL, "Can not establish standalone subsystem invocation."); else call com_err_ (code, PRINT_MAIL, "Can not establish standalone subsystem invocation."); return; end; call ssu_$arg_count (sci_ptr, n_arguments); /* will abort if not a command */ /* Initialize default options: reading the user's profile will go here someday */ have_mailbox = "0"b; /* haven't seen a mailbox yet */ local_oo.version = OPEN_OPTIONS_VERSION_2; local_oo.sender_selection_mode = ACCESSIBLE_MESSAGES; /* read all messages (if possible) */ local_oo.message_reading_level = READ_KEYS; /* will fetch messages one at a time (faster startup) */ mail, interactive_messages = "1"b; /* assume ordinary mail and interactive messages by default */ acknowledge, display_message_count = "1"b; /* -acknowledge, -count */ brief, list, reverse = "0"b; /* -long, -no_list, -no_reverse */ local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = 0; /* use line length of the terminal */ local_fmo.include_body = "1"b; formatting_mode = DEFAULT_FORMATTING_MODE; /* default formatting (-header) */ /* Process arguments */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode, /* logbox/savebox must already exist */ local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; string (local_pcao.flags) = ""b; local_pcao.abort_on_errors = "1"b; /* any errors are immediately fatal */ local_pcao.validate_addresses = "1"b; /* insure that any mailbox specified actually exists */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-brief") | (argument = "-bf") then brief = "1"b; else if (argument = "-long") | (argument = "-lg") then brief = "0"b; else if (argument = "-long_header") | (argument = "-lghe") then formatting_mode = LONG_FORMATTING_MODE; else if (argument = "-header") | (argument = "-he") then formatting_mode = DEFAULT_FORMATTING_MODE; else if (argument = "-brief_header") | (argument = "-bfhe") then formatting_mode = BRIEF_FORMATTING_MODE; else if (argument = "-no_header") | (argument = "-nhe") then formatting_mode = NONE_FORMATTING_MODE; else if (argument = "-acknowledge") | (argument = "-ack") then acknowledge = "1"b; else if (argument = "-no_acknowledge") | (argument = "-nack") then acknowledge = "0"b; else if (argument = "-interactive_messages") | (argument = "-im") then interactive_messages = "1"b; else if (argument = "-no_interactive_messages") | (argument = "-nim") then interactive_messages = "0"b; else if (argument = "-mail") | (argument = "-ml") then mail = "1"b; else if (argument = "-no_mail") | (argument = "-nml") then mail = "0"b; else if (argument = "-count") | (argument = "-ct") then display_message_count = "1"b; else if (argument = "-no_count") | (argument = "-nct") then display_message_count = "0"b; else if (argument = "-reverse") | (argument = "-rv") then reverse = "1"b; else if (argument = "-no_reverse") | (argument = "-nrv") then reverse = "0"b; else if (argument = "-list") | (argument = "-ls") then list = "1"b; else if (argument = "-no_list") | (argument = "-nls") then list = "0"b; else if (argument = "-accessible") | (argument = "-acc") then local_oo.sender_selection_mode = ACCESSIBLE_MESSAGES; else if (argument = "-all") | (argument = "-a") then local_oo.sender_selection_mode = ALL_MESSAGES; else if argument = "-own" then local_oo.sender_selection_mode = OWN_MESSAGES; else if argument = "-not_own" then local_oo.sender_selection_mode = NOT_OWN_MESSAGES; else if (argument = "-debug") | (argument = "-db") then call ssu_$set_debug_mode (sci_ptr, "1"b); else if (argument = "-no_debug") | (argument = "-ndb") then call ssu_$set_debug_mode (sci_ptr, "0"b); else go to TRY_ARGUMENT_AS_MAILBOX_PATHNAME; /* unknown control argument: maybe a mailbox specifier? */ else do; TRY_ARGUMENT_AS_MAILBOX_PATHNAME: /* not a control argument: must be a mailbox specifier */ call mlsys_utils_$parse_mailbox_control_args (sci_ptr, argument_idx, addr (local_pcao), mailbox_dirname, mailbox_ename, (0)); /* ... above entrypoint aborts us if anything's wrong */ argument_idx = argument_idx - 1; /* ... do loop will increment it */ if have_mailbox then /* ... this one's OK and we already have one (sigh) */ call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one mailbox may be specified."); have_mailbox = "1"b; /* ... now we've got the mailbox to be printed */ end; end; if ^mail & ^interactive_messages then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, """-no_mail"" and ""-no_interactive_messages"""); if mail & interactive_messages then /* want all types of messages */ local_oo.message_selection_mode = ALL_MESSAGES; else if mail then /* only want ordinary mail messages */ local_oo.message_selection_mode = ORDINARY_MESSAGES; else local_oo.message_selection_mode = INTERACTIVE_MESSAGES; /* interactive messages only */ if formatting_mode = BRIEF_FORMATTING_MODE then do; local_fmo.envelope_formatting_mode = NONE_FORMATTING_MODE; local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = BRIEF_FORMATTING_MODE; end; else local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = formatting_mode; /* If no mailbox was given on the command line, use the user's default mailbox which is created if necessary */ if ^have_mailbox then do; call mail_system_$get_address_pathname (mlsys_data_$user_default_mailbox_address, mailbox_dirname, mailbox_ename, ((32)" "), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting the pathname of your mailbox."); call mlsys_utils_$create_default_mailbox (code); if code = 0 then /* just created it ... */ call ssu_$print_message (sci_ptr, 0, "Created ^a.", pathname_ (mailbox_dirname, mailbox_ename)); else if code ^= mlsys_et_$mailbox_exists then call ssu_$abort_line (sci_ptr, code, "Attempting to create your default mailbox. ^a", pathname_ (mailbox_dirname, mailbox_ename)); end; /* Open the mailbox, check the salvaged flag, and report the message count */ call mail_system_$open_mailbox (mailbox_dirname, mailbox_ename, addr (local_oo), MAILBOX_VERSION_2, mailbox_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to open ^a.", pathname_ (mailbox_dirname, mailbox_ename)); if mailbox.mailbox_type = USER_DEFAULT_MAILBOX then mailbox_printing_name = "your mailbox"; else if mailbox.mailbox_type = USER_LOGBOX then mailbox_printing_name = "your logbox"; else mailbox_printing_name = pathname_ (mailbox_dirname, mailbox_ename); if mailbox.salvaged then /* something was probably lost ... */ if brief then call ssu_$print_message (sci_ptr, 0, "Mailbox has been salvaged."); else call ssu_$print_message (sci_ptr, 0, "Warning: ^a^a has been salvaged since it was last read.^/Some messages may have been lost.", translate (substr (mailbox_printing_name, 1, 1), "Y", "y"), substr (mailbox_printing_name, 2)); if display_message_count then /* user wants to know how much is there */ if mailbox.n_messages = 0 then if brief then call ioa_ ("No mail."); else call ioa_ ("^[You have no mail^s^;^[You have no messages^;There is no mail^]^]^[ in ^a^].", (mailbox.mailbox_type = USER_DEFAULT_MAILBOX), (mailbox.sender_selection_mode = OWN_MESSAGES), (mailbox.mailbox_type ^= USER_DEFAULT_MAILBOX), mailbox_printing_name); else if mailbox.n_messages = 1 then if brief then call ioa_ ("One message."); else call ioa_ ( "^[You have one message^s^;^[You have one message^;There is one message^]^]^[ in ^a^].", (mailbox.mailbox_type = USER_DEFAULT_MAILBOX), (mailbox.sender_selection_mode = OWN_MESSAGES), (mailbox.mailbox_type ^= USER_DEFAULT_MAILBOX), mailbox_printing_name); else /*** if mailbox.n_messages > 1 then */ do; if brief then call ioa_ ("^d messages.", mailbox.n_messages); else call ioa_ ("^[You have^s^;^[You have^;There are^]^] ^d messages^[ in ^a^].", (mailbox.mailbox_type = USER_DEFAULT_MAILBOX), (mailbox.sender_selection_mode = OWN_MESSAGES), mailbox.n_messages, (mailbox.mailbox_type ^= USER_DEFAULT_MAILBOX), mailbox_printing_name); end; if mailbox.n_messages = 0 then go to RETURN_FROM_PRINT_MAIL; /* mailbox is empty: nothing else to do */ /* Mailbox is open and there are messages present: this invocation is, therefore, going to do some real work */ if first_invocation then call ssu_$print_blast (sci_ptr, codeptr (print_mail), 3, PRINT_MAIL_SPECIAL_MESSAGE, (0)); else call ssu_$record_usage (sci_ptr, codeptr (print_mail), (0)); first_invocation = "0"b; if reverse then do; /* go backwards through the messages */ first_message = mailbox.n_messages; last_message = 1; direction = -1; end; else do; /* go forward through the messages */ first_message = 1; last_message = mailbox.n_messages; direction = 1; end; /* Summarize the messages if requested via "-list" */ if list then do; call mlsys_utils_$print_message_summary_header (0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Printing listing header line."); do current_message = first_message to last_message by direction; call mail_system_$read_message (mailbox_ptr, current_message, code); if code ^= 0 then /* couldn't read the message */ call ssu_$abort_line (sci_ptr, code, "Reading message #^d from ^a.", current_message, mailbox_printing_name); message_ptr = mailbox.messages (current_message).message_ptr; call mlsys_utils_$print_message_summary (message_ptr, current_message, "0"b, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Printing listing of message #^d.", current_message); end; end; %page; /* Main processing loop: print a message and ask user for disposition */ query_info.version = query_info_version_5; processing_message = "0"b; /* handler only valid when playing with a message */ on condition (program_interrupt) begin; if processing_message then go to ASK_MESSAGE_DISPOSITION; else call continue_to_signal_ ((0)); end; do current_message = first_message to last_message by direction; REPRINT_THE_MESSAGE: if mailbox.messages (current_message).message_ptr = null () then do; call mail_system_$read_message (mailbox_ptr, current_message, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Reading message #^d from ^a. No messages will be deleted.", current_message, mailbox_printing_name); end; message_ptr = mailbox.messages (current_message).message_ptr; processing_message = "1"b; /* now OK to ask the disposition */ /*** following ioa_ call is OK until messages appear with sections that aren't preformatted */ call ioa_ ("^/ #^d^[ (^d line^[s^] in body)^]:", current_message, (message.total_lines ^= -1), message.total_lines, (message.total_lines ^= 1)); call mlsys_utils_$print_message (message_ptr, addr (local_fmo), iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to print message #^d. No messages will be deleted.", current_message); call ioa_ (" ---(^d)---", current_message); call iox_$control (iox_$user_output, "reset_more", null (), (0)); if acknowledge & message.must_be_acknowledged then call mail_system_$acknowledge_message (message_ptr, (0)); ASK_MESSAGE_DISPOSITION: call command_query_ (addr (query_info), disposition, PRINT_MAIL, "Delete #^d?", current_message); if disposition = "y" then disposition = "yes"; else if disposition = "n" then disposition = "no"; else if disposition = "q" then disposition = "quit"; else if (disposition = "print") | (disposition = "pr") | (disposition = "p") then disposition = "reprint"; if disposition = "yes" then do; /* mark the message for deletion */ if message.can_be_deleted then call mail_system_$mark_message_for_deletion (message_ptr, code); else code = mlsys_et_$cant_be_deleted; if code ^= 0 then /* ... couldn't delete it */ if code = mlsys_et_$cant_be_deleted then call ssu_$print_message (sci_ptr, 0, "Insufficient access to delete message #^d. Continuing to next message.", current_message); else call ssu_$abort_line (sci_ptr, code, "Attempting to delete message #^d. No messages will be deleted.", current_message); end; else if disposition = "no" then /* do not delete this message */ if message.marked_for_deletion then do; /* ... and somehow they changed their mind */ call mail_system_$unmark_message_for_deletion (message_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to retrieve message #^d. No messages will be deleted.", current_message); end; else ; /* ... but it's not marked for deletion anyway */ else if disposition = "reprint" then /* reprint the message and ask again */ go to REPRINT_THE_MESSAGE; else if disposition = "quit" then /* delete marked messages and exit */ go to DELETE_MESSAGES; else if disposition = "abort" then /* exit without deleting any marked messages */ go to RETURN_FROM_PRINT_MAIL; else if disposition = "?" then do; call ioa_ ("Acceptable answers and meanings:"); call ioa_ ("^3xyes^15tMark this message for deletion."); call ioa_ ("^3xno^15tLeave this message untouched."); call ioa_ ("^3xreprint^15tRe-print the most recent message."); call ioa_ ("^3xquit^15tExit print_mail and delete all message marked for deletion."); call ioa_ ("^3xabort^15tExit print_mail without deleting any messages."); call ioa_ ("^3x?^15tPrint this list."); call ioa_ ("Use the program_interrupt command after interrupting the printing of a message."); go to ASK_MESSAGE_DISPOSITION; end; else do; /* unknown answer */ call ssu_$print_message (sci_ptr, 0, "Unrecognized answer ""^a"". Type ""?"" for a request list.", disposition); go to ASK_MESSAGE_DISPOSITION; end; processing_message = "0"b; /* done with this message: shut off pi handler */ end; %page; /* User exited the main loop either by "quit" or reading all messages: delete any messages marked for deletion */ DELETE_MESSAGES: processing_message = "0"b; /* make sure this is off */ on condition (sub_error_) begin; /* in case something goes wrong while deleting */ dcl 1 ci aligned like condition_info; ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= "mail_system_" then do; call continue_to_signal_ ((0)); /* not being reported by the mail system */ go to CONTINUE_FROM_HANDLER; end; delete_error_info_ptr = sub_error_info.info_ptr; call ssu_$print_message (sci_ptr, delete_error_info.code, "Unable to delete message #^d.^[ ^a^] Deletion of other messages continues.", delete_error_info.message_number, (length (delete_error_info.additional_info) > 0), delete_error_info.additional_info); go to CALL_EXPUNGE_MESSAGES; CONTINUE_FROM_HANDLER: end; CALL_EXPUNGE_MESSAGES: call mail_system_$expunge_messages (mailbox_ptr, code); revert condition (sub_error_); %page; /* User exited the mail loop via "abort": do not delete any messages; also the target of error transfers */ RETURN_FROM_PRINT_MAIL: processing_message = "0"b; /* make sure this is off */ call release_data_structures (); return; /* Release any data structures created herein */ release_data_structures: procedure (); dcl 1 local_co aligned like close_options; if mailbox_ptr ^= null () then do; /* close the mailbox (and don't delete anything) */ local_co.version = CLOSE_OPTIONS_VERSION_2; string (local_co.flags) = ""b; /* ... sets perform_deletions off */ call mail_system_$close_mailbox (mailbox_ptr, addr (local_co), (0)); end; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end release_data_structures; /* Invoked by ssu_$abort_line and ssu_$abort_subsystem to terminate execution of print_mail */ abort_print_mail_command: procedure (); go to RETURN_FROM_PRINT_MAIL; end abort_print_mail_command; %page; %include mlsys_mailbox; %page; %include mlsys_message; %page; %include mlsys_open_options; %include mlsys_delete_error_info; %include mlsys_close_options; %page; %include mlsys_parse_ca_options; %page; %include mlsys_format_options; %page; %include query_info; %page; %include condition_info; %include sub_error_info; %include condition_info_header; end print_mail;  rdm_apply_request_.pl1 10/02/89 0908.5rew 10/02/89 0816.9 133218 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - added message_type parameter to call to rdm_message_mark_mgr_$mark_current_message to catch use of "-odl" when defaulting to the current message. 2) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - the new entry set_new_current_msg in rdm_mailbox_interface_ is now called when the current message is changed to guarantee that the new current message is never a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* The read_mail apply request */ /* Created: 1979 by Gary C. Dixon as an interim version (not capable of modifying the actual message) */ /* Modified: 3 June 1980 by G. Palter to implement suggestion #0263 -- the current message in read_mail should be set to the message being processed; thus, if an error occurs, the current message will remain on which the error occured */ /* Modified: 12 March 1982 by G. Palter to implement -include_deleted, -only_deleted, and -only_non_deleted and to fix a bug which caused -no_header to sometimes fail */ /* Modified: 28 September 1982 by G. Palter to add appropriate negative control arguments */ /* Modified: October 1983 by G. Palter as part of the conversion to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_apply_request_: procedure (); return; /* not an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; dcl original_formatted_message character (original_formatted_message_lth) unaligned based (original_formatted_message_ptr); dcl original_formatted_message_ptr pointer; dcl original_formatted_message_lth fixed binary (21); dcl formatted_message character (formatted_message_lth) unaligned based (formatted_message_ptr); dcl new_formatted_message character (new_formatted_message_lth) unaligned based (formatted_message_ptr); dcl formatted_message_ptr pointer; dcl (formatted_message_lth, new_formatted_message_lth) fixed binary (21); dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, first_command_argument_idx, argument_idx) fixed binary; dcl msg_spec_array (msg_spec_array_size) fixed binary based (msg_spec_array_ptr); dcl msg_spec_array_ptr pointer; dcl (msg_spec_array_size, msg_spec_count, msg_type) fixed binary; dcl (reverse_sw, delete_sw, header_sw, message_sw) bit (1) aligned; dcl (first_message_idx, last_message_idx, message_idx_increment, message_idx, message_number) fixed binary; dcl message_ptr pointer; dcl code fixed binary (35); dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (error_table_$badopt, error_table_$inconsistent, error_table_$noarg, error_table_$smallarg, mlsys_et_$message_too_large) fixed binary (35) external; /* format: on */ dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl mlsys_utils_$format_message entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl rdm_mailbox_interface_$delete_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$set_new_current_msg entry (ptr, fixed binary, fixed binary); dcl rdm_mailbox_interface_$mark_processed_and_acknowledge entry (pointer, fixed binary); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$mark_current_message entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$validate_message_specifier entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$apply_request_util entry (pointer, fixed binary, pointer, fixed binary (21), fixed binary (21)); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_request_name entry (pointer) returns (character (32)); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl cleanup condition; dcl (addr, currentsize, hbound, index, null) builtin; %page; apply_request: entry (P_sci_ptr, P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments = 0 then PRINT_USAGE_MESSAGE: call ssu_$abort_line (P_sci_ptr, 0, "Usage: ^a {message_specifier} {-control_args} command_line", ssu_$get_request_name (P_sci_ptr)); call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); msg_spec_array_size = n_arguments; /* set up the pointer array */ call cu_$grow_stack_frame (currentsize (msg_spec_array), msg_spec_array_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Too many message specifiers in request line."); msg_spec_count = 0; /* no message specifiers yet */ msg_type = NON_DELETED_MESSAGES; /* Process arguments: if first argument isn't a message specifier, it starts the command line; otherwise, the first non-control argument starts the command line */ header_sw = "1"b; /* apply operation to the header ... */ message_sw = "1"b; /* ... and the text ... */ delete_sw = "0"b; /* ... and do not delete when done */ reverse_sw = "0"b; /* ... and in ascending order */ argument_idx = 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); call rdm_message_mark_mgr_$validate_message_specifier (rdm_invocation_ptr, argument_ptr, argument_lth, ALL_MESSAGES, ""b, code); if code = 0 then do; /* first argument is a message specifier */ call process_argument_as_spec (); argument_idx = 2; /* ... so start parsing at second argument */ end; first_command_argument_idx = 0; /* haven't found it yet */ do argument_idx = argument_idx to n_arguments while (first_command_argument_idx = 0); call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-include_deleted") | (argument = "-idl") | (argument = "-all") | (argument = "-a") then msg_type = ALL_MESSAGES; else if (argument = "-only_deleted") | (argument = "-odl") then msg_type = ONLY_DELETED_MESSAGES; else if (argument = "-only_non_deleted") | (argument = "-ondl") then msg_type = NON_DELETED_MESSAGES; else if (argument = "-reverse") | (argument = "-rv") then reverse_sw = "1"b; else if (argument = "-no_reverse") | (argument = "-nrv") then reverse_sw = "0"b; else if (argument = "-delete") | (argument = "-dl") then delete_sw = "1"b; else if (argument = "-no_delete") | (argument = "-ndl") then delete_sw = "0"b; else if (argument = "-header") | (argument = "-he") then header_sw = "1"b; else if (argument = "-no_header") | (argument = "-nhe") then header_sw = "0"b; else if argument = "-text" then message_sw = "1"b; else if argument = "-no_text" then message_sw = "0"b; else if (argument = "-message") | (argument = "-msg") then do; if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "A message specifier must follow ""^a"".", argument); argument_idx = argument_idx + 1; call process_argument_as_spec (); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else first_command_argument_idx = argument_idx; end; if first_command_argument_idx = 0 then go to PRINT_USAGE_MESSAGE; /* no command line present */ if ^header_sw & ^message_sw then call ssu_$abort_line (P_sci_ptr, error_table_$inconsistent, """-no_text"" and ""-no_header"""); /* Mark appropriate messages */ formatted_message_ptr, /* for cleanup handler */ original_formatted_message_ptr = null (); on condition (cleanup) begin; if original_formatted_message_ptr ^= null () then call ssu_$release_temp_segment (P_sci_ptr, original_formatted_message_ptr); if formatted_message_ptr ^= null () then call ssu_$release_temp_segment (P_sci_ptr, formatted_message_ptr); end; call ssu_$get_temp_segment (P_sci_ptr, "original-message", original_formatted_message_ptr); call ssu_$get_temp_segment (P_sci_ptr, "apply-buffer", formatted_message_ptr); if msg_spec_count = 0 then /* defaults to the current message */ call rdm_message_mark_mgr_$mark_current_message (rdm_invocation_ptr, msg_type); /* phx19099 RL - "-odl" will be caught if specified during marking of current message */ else call process_msg_specs (); if reverse_sw then do; /* process messages in opposite of marked order */ first_message_idx = marked_chain.n_messages; last_message_idx = 1; message_idx_increment = -1; end; else do; /* process messages in the order marked */ first_message_idx = 1; last_message_idx = marked_chain.n_messages; message_idx_increment = 1; end; /* Process the messages */ do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); /* phx18564 RL - set current message to message_number only if it is not a deleted message; otherwise current set to next non-deleted message after message_number */ call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, message_number, rdm_invocation.current_message); /* each message is current as it's processed */ call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); call prepare_message_for_apply (); /* make two formatted copies of the message */ call ssu_$apply_request_util (rdm_invocation.sci_ptr, first_command_argument_idx, formatted_message_ptr, original_formatted_message_lth, new_formatted_message_lth); if new_formatted_message_lth ^= original_formatted_message_lth then MESSAGE_MODIFIED_ERROR: /* messages can not be modified */ call ssu_$abort_line (P_sci_ptr, 0, "This request can not be used to modify the messages in a mailbox."); if new_formatted_message ^= original_formatted_message then go to MESSAGE_MODIFIED_ERROR; call rdm_mailbox_interface_$mark_processed_and_acknowledge (rdm_invocation_ptr, message_number); end; /* Clean up */ if original_formatted_message_ptr ^= null () then call ssu_$release_temp_segment (P_sci_ptr, original_formatted_message_ptr); if formatted_message_ptr ^= null () then call ssu_$release_temp_segment (P_sci_ptr, formatted_message_ptr); if delete_sw then /* user wants the messages deleted */ call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, "0"b); return; %page; /* Remembers that the current argument is a message specifier */ process_argument_as_spec: procedure (); if msg_spec_count >= hbound (msg_spec_array, 1) then call ssu_$abort_line (P_sci_ptr, 0, "Too many message specifiers in request."); /* can't ever happen */ msg_spec_count = msg_spec_count + 1; msg_spec_array (msg_spec_count) = argument_idx; return; end process_argument_as_spec; /* Processes the array of message specifiers by marking all appropriate messages */ process_msg_specs: procedure (); dcl idx fixed binary; do idx = 1 to msg_spec_count; call ssu_$arg_ptr (P_sci_ptr, msg_spec_array (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, msg_type, ""b, code); if code ^= 0 then /* above call should abort on errors */ call ssu_$abort_line (P_sci_ptr, code); end; return; end process_msg_specs; %page; /* Prepares the message for the applied command line: Two formatted copies of the message are created in order to check that the command line does not modify the message as rewriting the message is not supported in this release */ prepare_message_for_apply: procedure (); dcl 1 local_fmo aligned like format_message_options; local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = 72; /* make the header look reasonable to the user */ if header_sw then /* include the header */ local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE; else local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = NONE_FORMATTING_MODE; local_fmo.include_body = message_sw; /* user's controls whether the text is present */ original_formatted_message_lth = 0; /* nothing used yet */ call mlsys_utils_$format_message (message_ptr, addr (local_fmo), original_formatted_message_ptr, (4 * sys_info$max_seg_size), original_formatted_message_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Preparing message #^d for processing.", message_number); formatted_message_lth = original_formatted_message_lth; formatted_message = original_formatted_message; /* make the actual copy given to the command line */ return; end prepare_message_for_apply; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include mlsys_format_options; end rdm_apply_request_;  rdm_data_.cds 07/26/88 1057.8rew 07/26/88 1013.4 85788 /* *********************************************************** * * * 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-03-25,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Changed version to 9.3. 2) change(86-08-26,Margolin), approve(86-08-26,MCR7508), audit(86-08-27,Blair), install(86-08-29,MR12.0-1142): Changed version to 9.3a. 3) change(88-04-14,Blair), approve(88-04-14,MCR7842), audit(88-06-29,Lippard), install(88-07-26,MR12.2-1069): Increment the version number to reflect the changes for SCP6349, add search path capability to the mail system. END HISTORY COMMENTS */ /* format: off */ /* Constant data used by the read_mail subsystem */ /* Created: 14 March 1978 by G. Palter */ /* Modified: 20 June 1978 by G. Palter to add info_directory */ /* Converted: 4 July 1978 by W. Olin Sibert from sdm_data_ */ /* Modified: 29 December 1979 by W. Olin Sibert */ /* Modified: 21 September 1982 by G. Palter to add ec_suffix and ec_search_list and remove several obsolete data items */ /* Recoded: September 1983 by G. Palter to use new argument processing for EXL/installed decision, to make the subsystem version a single character string, and to eliminate constants no longer used after converting to the mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_data_: procedure () options (variable); dcl 1 rdm_constants aligned, 2 version character (32) varying, 2 info_directory character (168) unaligned, 2 special_message character (256) varying, 2 ec_suffix character (32) unaligned, 2 ec_search_list character (32) unaligned; dcl 1 rdm_static aligned, 2 first_invocation bit (1) aligned; dcl 1 cds_data aligned like cds_args; /* arguments to create_data_segment_ subr */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl subsystem_type fixed binary; /* unbundled/exl/development */ dcl subsystem_version character (32) varying; dcl subsystem_info_directory character (168); dcl special_message character (256) varying; dcl special_message_given bit (1) aligned; dcl code fixed binary (35); dcl RDM_DATA_ character (32) static options (constant) initial ("rdm_data_"); dcl DEFAULT_SUBSYSTEM_VERSION character (28) varying static options (constant) initial ("9.3b"); dcl DEFAULT_SPECIAL_MESSAGE character (256) varying static options (constant) initial (""); dcl UNBUNDLED_SUBSYSTEM fixed binary static options (constant) initial (1); dcl UNBUNDLED_INFO_DIRECTORY character (168) static options (constant) initial (">doc>subsystem>mail_system>read_mail"); dcl EXL_SUBSYSTEM fixed binary static options (constant) initial (2); dcl EXL_INFO_DIRECTORY character (168) static options (constant) initial (">exl>mail_system_dir>info>read_mail"); dcl DEVELOPMENT_SUBSYSTEM fixed binary static options (constant) initial (3); dcl DEVELOPMENT_INFO_DIRECTORY character (168) static options (constant) initial (">udd>Multics>Palter>work>mail_system>info>read_mail"); /* format: off */ dcl (error_table_$bad_arg, error_table_$badopt, error_table_$bigarg) fixed binary (35) external; /* format: on */ dcl cu_$arg_count entry (fixed binary, fixed binary (35)); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (pointer, fixed binary (35)); dcl (addr, currentsize, index, maxlength, null, string) builtin; %page; /* Determine which type (unbundled/EXL/development) and version of the subsystem is being created */ call cu_$arg_count (n_arguments, code); if code ^= 0 then do; /* not a command */ call com_err_ (code, RDM_DATA_); return; end; subsystem_type = UNBUNDLED_SUBSYSTEM; subsystem_version = DEFAULT_SUBSYSTEM_VERSION; special_message_given = "0"b; /* default depends on the subsystem version */ do argument_idx = 1 to n_arguments; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, RDM_DATA_, "Fetching argument #^d.", argument_idx); return; end; if index (argument, "-") = 1 then /* a control argument ... */ if (argument = "-unbundled") | (argument = "-unb") then subsystem_type = UNBUNDLED_SUBSYSTEM; else if (argument = "-experimental") | (argument = "-exl") then subsystem_type = EXL_SUBSYSTEM; else if (argument = "-development") | (argument = "-dev") then subsystem_type = DEVELOPMENT_SUBSYSTEM; else if argument = "-version" then do; /* specific value for the subsystem version */ if argument_idx = n_arguments then do; call com_err_ (code, RDM_DATA_, "Version string following ""^a"".", argument); return; end; argument_idx = argument_idx + 1; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, RDM_DATA_, "Fetching argument #^d.", argument_idx); return; end; if argument_lth > maxlength (DEFAULT_SUBSYSTEM_VERSION) then do; call com_err_ (error_table_$bigarg, RDM_DATA_, "Maximum length for the version string is ^d characters. ""^a""", maxlength (DEFAULT_SUBSYSTEM_VERSION), argument); return; end; subsystem_version = argument; end; else if (argument = "-message") | (argument = "-msg") then do; if argument_idx = n_arguments then do; call com_err_ (code, RDM_DATA_, "Special message text following ""^a"".", argument); return; end; argument_idx = argument_idx + 1; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, RDM_DATA_, "Fetching argument #^d.", argument_idx); return; end; if argument_lth > maxlength (special_message) then do; call com_err_ (error_table_$bigarg, RDM_DATA_, "Maximum length for the special message is ^d characters. ""^a""", maxlength (special_message), argument); return; end; special_message = argument; special_message_given = "1"b; end; else if (argument = "-no_message") | (argument = "-nmsg") then do; special_message = ""; /* developer wants no message for this version */ special_message_given = "1"b; end; else do; call com_err_ (error_table_$badopt, RDM_DATA_, """^a""", argument); return; end; else do; call com_err_ (error_table_$bad_arg, RDM_DATA_, """^a""", argument); return; end; end; /* Supply appropriate default values for the special message and subsystem info directory based on the type and version */ if ^special_message_given then /* defaults to builtin message only if builtin version */ if subsystem_version = DEFAULT_SUBSYSTEM_VERSION then special_message = DEFAULT_SPECIAL_MESSAGE; else special_message = ""; /* ... any other version must have the message supplied */ if subsystem_type = UNBUNDLED_SUBSYSTEM then subsystem_info_directory = UNBUNDLED_INFO_DIRECTORY; else if subsystem_type = EXL_SUBSYSTEM then do; subsystem_version = subsystem_version || " EXL"; subsystem_info_directory = EXL_INFO_DIRECTORY; end; else /*** if subsystem_type = DEVELOPMENT_SUBSYSTEM then */ do; subsystem_version = subsystem_version || " dev"; subsystem_info_directory = DEVELOPMENT_INFO_DIRECTORY; end; /* Define values for the constant data used by the subsystem */ rdm_constants.version = subsystem_version; rdm_constants.info_directory = subsystem_info_directory; rdm_constants.special_message = special_message; rdm_constants.ec_suffix = "rdmec"; /* use non-default exec_com suffix and search list */ rdm_constants.ec_search_list = "mail_system"; /* Define initial values for the static used by the subsystem */ rdm_static.first_invocation = "1"b; /* force the initialization code to be run */ /* Set up arguments for call to create_data_segment_ */ cds_data.sections (1).p = addr (rdm_constants); cds_data.sections (1).len = currentsize (rdm_constants); cds_data.sections (1).struct_name = "rdm_constants"; cds_data.sections (2).p = addr (rdm_static); cds_data.sections (2).len = currentsize (rdm_static); cds_data.sections (2).struct_name = "rdm_static"; cds_data.seg_name = RDM_DATA_; cds_data.num_exclude_names = 0; cds_data.exclude_array_ptr = null (); string (cds_data.switches) = ""b; cds_data.switches.have_text, cds_data.switches.have_static = "1"b; cds_data.switches.separate_static = "1"b; /* Call create_data_segment_ */ call create_data_segment_ (addr (cds_data), code); if code ^= 0 then call com_err_ (code, RDM_DATA_); return; %page; %include cds_args; end rdm_data_;  rdm_debug_requests_.pl1 05/22/86 1102.1r w 05/22/86 1010.7 35226 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* Debugging requests for the read_mail subsystem */ /* Created: October 1982 by G. Palter */ /* Modified: 13 September 1983 by G. Palter as part of the conversion of read_mail to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_debug_requests_: procedure (P_sci_ptr, P_rdm_invocation_ptr); put file (rdm_debug_) data; /* forces a full symbol table ... */ return; /* ... but not really an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; dcl sci_ptr pointer; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl new_debug_mode bit (1) aligned; dcl code fixed binary (35); dcl rdm_debug_ file stream internal; dcl error_table_$bad_arg fixed binary (35) external; dcl error_table_$badopt fixed binary (35) external; dcl rdm_set_request_tables_ entry (pointer, fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$set_debug_mode entry (pointer, bit (1) aligned); dcl probe entry () options (variable); dcl index builtin; %page; /* The "debug_mode" request: enables/disables read_mail debugging facilities */ debug_mode: entry (P_sci_ptr, P_rdm_invocation_ptr); sci_ptr = P_sci_ptr; rdm_invocation_ptr = P_rdm_invocation_ptr; new_debug_mode = "1"b; /* defaults to turn on debug_mode */ call ssu_$arg_count (sci_ptr, n_arguments); do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if argument = "-on" then new_debug_mode = "1"b; else if argument = "-off" then new_debug_mode = "0"b; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "This request only accepts control arguments. ""^a""", argument); end; rdm_invocation.debug_mode = new_debug_mode; call ssu_$set_debug_mode (sci_ptr, (rdm_invocation.debug_mode)); /* keep ssu_ in step */ call rdm_set_request_tables_ (rdm_invocation_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting subsystem request tables."); return; %page; /* The "probe" request: invokes the probe symbolic debugger in a stack frame with all relavent data structure available */ probe: entry (P_sci_ptr, P_rdm_invocation_ptr); sci_ptr = P_sci_ptr; rdm_invocation_ptr = P_rdm_invocation_ptr; call ssu_$arg_count (sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (sci_ptr, 0, "No arguments may be supplied."); mailbox_ptr = rdm_invocation.mailbox_ptr; /* make it easy to access the mailbox ... */ if rdm_invocation.current_message ^= 0 then /* ... and the current message (if any) */ if message_list.messages (rdm_invocation.current_message).message_idx > 0 then message_ptr = mailbox.messages (message_list.messages (rdm_invocation.current_message).message_idx) .message_ptr; else message_ptr = null (); else message_ptr = null (); call probe (); return; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include mlsys_mailbox; %page; %include mlsys_message; %page; %include mlsys_address_list; end rdm_debug_requests_;  rdm_file_requests_.pl1 10/02/89 0908.5rew 10/02/89 0815.0 170757 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - passed additional message type to call to rdm_message_mark_mgr_$mark_current_message to catch use of "-odl" with the current message. 2) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - the new entry set_new_current_msg in rdm_mailbox_interface_ is now called when the current message is changed to guarantee that the new current message is never a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* The read_mail write, append, and preface requests */ /* Created: October 1983 by G. Palter from sdm_file_requests_ */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_file_requests_: procedure (P_sci_ptr, P_rdm_invocation_ptr); return; /* not an entrypoint */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; /* Local copies of parameters */ dcl sci_ptr pointer; /* Remaining declarations */ dcl message_specifier_idxs (n_message_specifiers_allocated) fixed binary based (message_specifier_idxs_ptr); dcl message_specifier_idxs_ptr pointer; dcl (n_message_specifiers_allocated, n_message_specifiers) fixed binary; dcl message_type fixed binary; /* all/only deleted/only non-deleted */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl message_buffer character (4 * sys_info$max_seg_size) unaligned based (message_buffer_ptr); dcl message_text character (message_text_lth) unaligned based (message_buffer_ptr); dcl message_buffer_ptr pointer; dcl message_text_lth fixed binary (21); dcl 1 local_fmo aligned like format_message_options; dcl saved_rdm_sci_ptr pointer; dcl is_original_request bit (1) aligned; /* ON => invoked from send_mail within a reply request */ dcl (delete_after_processing, reverse_processing) bit (1) aligned; dcl file_dirname character (168); dcl file_ename character (32); dcl file_ptr pointer; dcl file_uid bit (36) aligned; dcl file_creation_mode fixed binary; dcl file_insertion_mode fixed binary; dcl have_filename bit (1) aligned; dcl code fixed binary (35); dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$nostars, mlsys_et_$message_too_large, ssu_et_$unimplemented_request) fixed binary (35) external; /* format: on */ dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl emf_writing_util_$close entry (pointer, bit (36) aligned, fixed binary (35)); dcl emf_writing_util_$open entry (pointer, character (*), character (*), fixed binary, pointer, bit (36) aligned, fixed binary (35)); dcl emf_writing_util_$write entry (pointer, bit (36) aligned, character (*), fixed binary, fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned); dcl mlsys_utils_$format_message entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl rdm_mailbox_interface_$delete_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$mark_processed_and_acknowledge entry (pointer, fixed binary); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_mailbox_interface_$set_new_current_msg entry (ptr, fixed binary, fixed binary); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$mark_current_message entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$remark_original_messages entry (pointer); dcl rdm_message_mark_mgr_$validate_message_specifier entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_request_name entry (pointer) returns (character (32)); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl cleanup condition; dcl (addr, index, length, null, size, substr) builtin; %page; /* The "write" request: adds the printed representation of the specified messages to the end of the specified file which is created if necessary without asking the user's permission */ write_request: entry (P_sci_ptr, P_rdm_invocation_ptr); call setup_request ("1"b); /* may be used as a send_mail original request */ saved_rdm_sci_ptr = rdm_invocation.sci_ptr; /* for cleanup handler */ on condition (cleanup) begin; call cleanup_request (); /* common to all requests */ rdm_invocation.sci_ptr = saved_rdm_sci_ptr; end; rdm_invocation.sci_ptr = P_sci_ptr; /* be sure to not abort the reply request by accident */ file_creation_mode = SILENTLY_CREATE_FILE; file_insertion_mode = APPEND_FILE; /* default is "-extend" */ call process_arguments ("1"b); /* allow -extend/-truncate */ call mark_appropriate_messages (); call process_messages (); /* do the actual work */ call cleanup_request (); rdm_invocation.sci_ptr = saved_rdm_sci_ptr; return; %page; /* The "append" request: adds the printed representation of the specified messages to the end of the specified file. The user is asked for permission to create the file if it doesn't exist */ append_request: entry (P_sci_ptr, P_rdm_invocation_ptr); file_insertion_mode = APPEND_FILE; /* ... at the end */ go to APPEND_PREFACE_COMMON; /* The "preface" request: adds the printed representation of the specified messages to the beginning of the specified file. The user is asked for permission to create the file if it doesn't exist */ preface_request: entry (P_sci_ptr, P_rdm_invocation_ptr); file_insertion_mode = PREFACE_FILE; /* ... at the beginning */ /* Process the append/preface request */ APPEND_PREFACE_COMMON: call setup_request ("0"b); /* may only be used from read_mail */ on condition (cleanup) call cleanup_request (); file_creation_mode = QUERY_TO_CREATE_FILE; call process_arguments ("0"b); /* can't change insertion mode */ call mark_appropriate_messages (); call process_messages (); /* do the actual work */ call cleanup_request (); return; %page; /* Prepares for the execution of one of the above requests */ setup_request: procedure (p_allow_original_request) /* options (quick) */; dcl p_allow_original_request bit (1) aligned parameter; sci_ptr = P_sci_ptr; rdm_invocation_ptr = P_rdm_invocation_ptr; if rdm_invocation.type = SDM_INVOCATION then /* a send_mail original request ... */ if p_allow_original_request then do; /* ... and that's OK */ is_original_request = "1"b; sdm_invocation_ptr = P_rdm_invocation_ptr; rdm_invocation_ptr = sdm_invocation.rdm_invocation_ptr; if rdm_invocation_ptr = null () then call ssu_$abort_line (sci_ptr, 0, "This request is valid only during a ""reply"" request."); end; else call ssu_$abort_line (sci_ptr, ssu_et_$unimplemented_request); else is_original_request = "0"b; /* an oprdinary read_mail request */ call ssu_$arg_count (sci_ptr, n_arguments); n_message_specifiers_allocated = n_arguments; /* can't have more message specifiers than arguments */ call cu_$grow_stack_frame (size (message_specifier_idxs), message_specifier_idxs_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Too many message specifiers on the request line."); n_message_specifiers = 0; /* haven't actually spotted any yet */ call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); file_ptr, message_buffer_ptr = null (); /* for cleanup handler */ return; end setup_request; /* Closes the file opened by this request and releases the message buffer */ cleanup_request: procedure (); if message_buffer_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, message_buffer_ptr); if file_ptr ^= null () then call emf_writing_util_$close (file_ptr, file_uid, (0)); return; end cleanup_request; %page; /* Processes the arguments for one of the above requests */ process_arguments: procedure (p_accept_extend_truncate); dcl p_accept_extend_truncate bit (1) aligned parameter; message_type = NON_DELETED_MESSAGES; reverse_processing = "0"b; /* default is to process in marked order */ delete_after_processing = "0"b; /* default is to not delete messages */ have_filename = "0"b; do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if ^is_original_request & ((argument = "-delete") | (argument = "-dl")) then delete_after_processing = "1"b; else if ^is_original_request & ((argument = "-no_delete") | (argument = "-ndl")) then delete_after_processing = "0"b; else if p_accept_extend_truncate & (argument = "-extend") then file_insertion_mode = APPEND_FILE; else if p_accept_extend_truncate & ((argument = "-truncate") | (argument = "-tc")) then file_insertion_mode = TRUNCATE_FILE; else if (argument = "-include_deleted") | (argument = "-idl") then message_type = ALL_MESSAGES; else if (argument = "-only_deleted") | (argument = "-odl") then message_type = ONLY_DELETED_MESSAGES; else if (argument = "-only_non_deleted") | (argument = "-ondl") then message_type = NON_DELETED_MESSAGES; else if (argument = "-reverse") | (argument = "-rv") then reverse_processing = "1"b; else if (argument = "-no_reverse") | (argument = "-nrv") then reverse_processing = "0"b; /*** the following control arguments are obsolete: remove them in MR11 */ else if (argument = "-all") | (argument = "-a") then message_type = ALL_MESSAGES; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else do; /* a message specifier or filename */ call rdm_message_mark_mgr_$validate_message_specifier (rdm_invocation_ptr, argument_ptr, argument_lth, ALL_MESSAGES, ""b, code); if code = 0 then do; /* ... it looks like a message specifier */ n_message_specifiers = n_message_specifiers + 1; message_specifier_idxs (n_message_specifiers) = argument_idx; end; else /* ... it must be the filename */ if have_filename then /* ... but we already have one */ call ssu_$abort_line (sci_ptr, 0, "Only one filename may be given. ""^a"" and ""^a""", pathname_ (file_dirname, file_ename), argument); else do; /* ... first filename */ have_filename = "1"b; call expand_pathname_$add_suffix (argument, "mail", file_dirname, file_ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, """^a""", argument); call check_star_name_$entry (file_ename, code); if code ^= 0 then /* ... either a sarname or an invalid name */ if (code = 1) | (code = 2) then call ssu_$abort_line (sci_ptr, error_table_$nostars, "^a", pathname_ (file_dirname, file_ename)); else call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (file_dirname, file_ename)); end; end; end; if ^have_filename then /* filename missing: usage message is better here */ call ssu_$abort_line (sci_ptr, 0, "Usage: ^a {message_specifiers} path {-control_args}", ssu_$get_request_name (sci_ptr)); return; end process_arguments; %page; /* Marks the appropriate messages for processing */ mark_appropriate_messages: procedure (); dcl idx fixed binary; if n_message_specifiers = 0 then /* defaults to ... */ if is_original_request then /* ... messages being answered if from send_mail */ call rdm_message_mark_mgr_$remark_original_messages (rdm_invocation_ptr); else /* ... current message if from read_mail */ call rdm_message_mark_mgr_$mark_current_message (rdm_invocation_ptr, message_type); /* phx19099 RL - "-odl" if specified will be caught when the current message is marked */ else do; /* use the messages requested by the user */ do idx = 1 to n_message_specifiers; call ssu_$arg_ptr (sci_ptr, message_specifier_idxs (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, message_type, ""b, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); end; end; return; end mark_appropriate_messages; %page; /* Processes the marked messages */ process_messages: procedure (); dcl (first_message_idx, last_message_idx, message_idx_increment, message_idx, message_number) fixed binary; call emf_writing_util_$open (sci_ptr, file_dirname, file_ename, file_creation_mode, file_ptr, file_uid, code); if code ^= 0 then /* couldn't open thje file ... */ if code = error_table_$action_not_performed then call ssu_$abort_line (sci_ptr, 0); /* ... and user answered "no" to the query to create it */ else call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (file_dirname, file_ename)); call ssu_$get_temp_segment (rdm_invocation.sci_ptr, "message_text", message_buffer_ptr); if reverse_processing then do; /* process them in the opposite order */ first_message_idx = marked_chain.n_messages; last_message_idx = 1; message_idx_increment = -1; end; else do; /* process them in the order marked */ first_message_idx = 1; last_message_idx = marked_chain.n_messages; message_idx_increment = 1; end; do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); /* phx18564 RL - set current message to message_number and guarantee that it's not deleted */ call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, message_number, rdm_invocation.current_message); /* it's current while we're working on it */ call process_single_message (); /* do the real work */ call rdm_mailbox_interface_$mark_processed_and_acknowledge (rdm_invocation_ptr, message_number); end; if delete_after_processing then /* user wants them deleted after processing */ call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, "0"b); return; %page; /* Internal to process_messages: processes a single message */ process_single_message: procedure (); local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = 72; local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE; local_fmo.include_body = "1"b; message_text_lth = 0; /* nothing in the buffer yet */ call add_to_buffer (" #^d^[ (^d line^[s^] in body)^]:", message_number, (message.body.total_lines ^= -1), message.body.total_lines, (message.body.total_lines ^= 1)); call mlsys_utils_$format_message (message_ptr, addr (local_fmo), message_buffer_ptr, length (message_buffer), message_text_lth, code); if code ^= 0 then /* ... error_table_$smallarg */ call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing message #^d to be written to ^a.", message_number, pathname_ (file_dirname, file_ename)); call add_to_buffer (" ---(^d)---^2/^|", message_number); call emf_writing_util_$write (file_ptr, file_uid, message_text, file_insertion_mode, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Writing message #^d to ^a.", message_number, pathname_ (file_dirname, file_ename)); if file_insertion_mode = TRUNCATE_FILE then /* only truncate the output file once, please */ file_insertion_mode = APPEND_FILE; return; /* Internal to process_single_message: formats the given text and adds it to the message buffer */ add_to_buffer: procedure () options (variable); dcl internal_buffer character (256); /* always called with relatively short messages */ dcl internal_buffer_used fixed binary (21); call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, internal_buffer, internal_buffer_used, "0"b, "1"b); begin; dcl rest_of_message_buffer character (length (message_buffer) - message_text_lth) unaligned defined (message_buffer) position (message_text_lth + 1); if internal_buffer_used > length (rest_of_message_buffer) then call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing message #^d to be written to ^a.", message_number, pathname_ (file_dirname, file_ename)); substr (rest_of_message_buffer, 1, internal_buffer_used) = substr (internal_buffer, 1, internal_buffer_used); end; message_text_lth = message_text_lth + internal_buffer_used; return; end add_to_buffer; end process_single_message; end process_messages; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include sdm_invocation; %page; %include emf_writing_modes; %page; %include mlsys_format_options; %page; %include mlsys_message; end rdm_file_requests_;  rdm_forward_request_.pl1 10/02/89 0908.5rew 10/02/89 0815.0 244287 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - added additional msg_type to call to rdm_message_mark_mgr_$mark_current_message to catch use of "-odl" with the current message. 2) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - the new entry set_new_current_msg in rdm_mailbox_interface_ is now called when the current message is changed to guarantee that the new current message is never a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* The read_mail forward request */ /* Created: 1978 by W. Olin Sibert */ /* Modified: 3 June 1980 by G. Palter to implement suggestion #0263 -- the current message in read_mail should be set to the message being processed; thus, if an error occurs, the current message will remain on which the error occured */ /* Modified: 28 September 1982 by G. Palter to add appropriate negative control arguments */ /* Modified: 20 December 1982 by G. Palter to fix the following entries on the mail_system error list: #0364 -- when given with no arguments, the forward request does not print a usefull error message; and #0408 -- the forward request does not recognize "-include_deleted", "-only_deleted", and "-only_non_deleted" */ /* Modified: October 1983 by G. Palter as part of the conversion to the new mail system interface. The capability to add a set of comments to the message(s) being forwarded was also implemented */ /* Modified: April 1984 by G. Palter to fix mail system error #0433 -- the send_mail command and all send_mail and read_mail requests which accept multiple addresses as arguments do not properly parse "-log -at HOST" */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_forward_request_: procedure (P_sci_ptr, P_rdm_invocation_ptr); return; /* not an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl msg_spec_array (msg_spec_array_size) fixed binary based (msg_spec_array_ptr); dcl msg_spec_array_ptr pointer; dcl (msg_spec_array_size, msg_spec_count, msg_type) fixed binary; dcl comment_buffer character (4 * sys_info$max_seg_size) unaligned based (comment_buffer_ptr); dcl comment_text character (comment_text_lth) unaligned based (comment_buffer_ptr); dcl comment_buffer_ptr pointer; dcl comment_text_lth fixed binary (21); dcl input_filename character (input_filename_lth) unaligned based (input_filename_ptr); dcl input_file_dirname character (168); dcl input_file_ename character (32); dcl input_filename_ptr pointer; dcl input_file_bitcount fixed binary (24); dcl input_filename_lth fixed binary (21); dcl profile_pathname character (profile_pathname_lth) unaligned based (profile_pathname_ptr); dcl profile_dirname character (168); dcl profile_ename character (32); dcl profile_pathname_ptr pointer; dcl profile_pathname_lth fixed binary (21); dcl (profile_pathname_given, abbrev_ca_given) bit (1) aligned; dcl 1 local_rfso aligned like rdm_forward_subsystem_options; dcl 1 local_pcao aligned like parse_ca_options; dcl 1 local_ri aligned, 2 header like recipients_info.header, 2 forwarding like recipients_info.lists; dcl 1 local_do aligned like deliver_options; dcl clear_original_message_chain bit (1) aligned; /* ON => we've marked the original messages */ dcl saved_current_message fixed binary; /* current message number before invoking forward subsystem */ dcl (first_message_idx, last_message_idx, message_idx_increment, message_idx, message_number) fixed binary; dcl message_ptr pointer; dcl (add_comments, reverse_sw, delete_sw, brief_sw) bit (1) aligned; dcl code fixed binary (35); dcl NULL_STRING character (1) static options (constant) initial (""); dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (emf_et_$forwarding_aborted, error_table_$bad_arg, error_table_$bad_conversion, error_table_$badopt, error_table_$noarg, mlsys_et_$message_not_sent, mlsys_et_$message_partially_sent) fixed binary (35) external; /* format: on */ dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl mail_system_$free_address_list entry (pointer, fixed binary (35)); dcl mail_system_$redistribute_message entry (pointer, character (*), pointer, pointer, fixed binary (35)); dcl mlsys_utils_$free_delivery_results entry (pointer, fixed binary (35)); dcl mlsys_utils_$parse_address_list_control_args entry (pointer, fixed binary, pointer, character (8), pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_delivery_results entry (pointer, bit (1) aligned, pointer, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl rdm_forward_subsystem_ entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl rdm_mailbox_interface_$delete_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$mark_processed_and_acknowledge entry (pointer, fixed binary); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_mailbox_interface_$set_new_current_msg entry (ptr, fixed binary, fixed binary); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$clear_original_messages entry (pointer); dcl rdm_message_mark_mgr_$mark_current_message entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$mark_original_messages entry (pointer); dcl rdm_message_mark_mgr_$validate_message_specifier entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned); dcl ssu_$get_request_name entry (pointer) returns (character (32)); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl cleanup condition; dcl (addr, currentsize, divide, hbound, index, length, null) builtin; %page; forward_request: entry (P_sci_ptr, P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments = 0 then /* must at least supply an address */ NO_FORWARDING_ADDRESSES: call ssu_$abort_line (P_sci_ptr, 0, "Usage: ^a {message_specifier} {addresses} {-control_args}", ssu_$get_request_name (P_sci_ptr)); call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); msg_spec_array_size = n_arguments; /* set up the message specifier indeces array */ call cu_$grow_stack_frame (currentsize (msg_spec_array), msg_spec_array_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Too many message specifiers in request line."); msg_spec_count = 0; /* haven't seen any message specifiers yet */ local_rfso.input_file_ptr, /* for cleanup handler */ comment_buffer_ptr, local_ri.expanded_recipients_result_list_ptr, local_ri.forwarding = null (); clear_original_message_chain = "0"b; on condition (cleanup) call cleanup_after_forward_request (); /* Setup default options */ msg_type = NON_DELETED_MESSAGES; /* default value */ reverse_sw, delete_sw = "0"b; brief_sw = rdm_invocation.brief; add_comments = "0"b; /* do not add comments to the message */ local_rfso.version = RDM_FORWARD_SUBSYSTEM_OPTIONS_VERSION_1; local_rfso.input_type = TERMINAL_INPUT; local_rfso.initial_requests_ptr = null (); local_rfso.initial_requests_lth = 0; local_rfso.enter_request_loop = DEFAULT_REQUEST_LOOP; local_rfso.fill_width = 62; /* comments are indented by 10 spaces */ local_rfso.enable_filling = DEFAULT_FILL; local_rfso.enable_prompt = DEFAULT_PROMPT; local_rfso.default_profile_ptr, local_rfso.profile_ptr = null (); abbrev_ca_given = "0"b; /* haven't seen -ab/-nab: use read_mail abbrev state */ profile_pathname_given = "0"b; /* no -profile yet */ local_rfso.auto_write = "0"b; /* -no_auto_write (good) */ local_rfso.pad = ""b; local_ri.area_ptr = get_system_free_area_ (); local_ri.n_lists = 1; local_ri.version = RECIPIENTS_INFO_VERSION_2; local_do.version = DELIVER_OPTIONS_VERSION_2; local_do.delivery_mode = ORDINARY_DELIVERY; /* forwarding is always ordinary mail */ local_do.queueing_mode = ALWAYS_QUEUE_FOREIGN; /* always queue foreign addresses & local when needed */ local_do.queued_notification_mode = NOTIFY_ON_ERROR; local_do.abort = "1"b; /* don't send it unless all recipients are OK */ local_do.send_if_empty = "1"b; /* let user forward anything they want to */ local_do.recipient_notification = "1"b; /* default is -notify */ local_do.acknowledge = "0"b; /* default is -no_acknowledge */ local_do.queue_mailing_lists = "0"b; local_do.mbz = ""b; local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = CREATE_AND_ANNOUNCE_MAILBOX; local_pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX; local_pcao.abort_on_errors = "1"b; /* stop immediately on an invalid address */ local_pcao.validate_addresses = "1"b; /* insure that we can send the mail */ local_pcao.mbz = ""b; /* Process arguments: check if first argument is a valid message specifier; otherwise, try using it as an address */ call ssu_$arg_ptr (P_sci_ptr, 1, argument_ptr, argument_lth); call rdm_message_mark_mgr_$validate_message_specifier (rdm_invocation_ptr, argument_ptr, argument_lth, ALL_MESSAGES, ""b, code); if code = 0 then do; /* seems to be a message specifier all right */ argument_idx = 1; /* ... neede by process_argument_as_spec */ call process_argument_as_spec (); argument_idx = 2; /* ... so addresses start with the 2nd argument */ end; else argument_idx = 1; /* not a message specifier: must be an address */ /* Process remaining arguments */ do while (argument_idx <= n_arguments); call mlsys_utils_$parse_address_list_control_args (P_sci_ptr, argument_idx, addr (local_pcao), ADDRESS_LIST_VERSION_2, local_ri.forwarding.address_list_ptr, local_ri.forwarding.address_list_ptr, code); if code ^= 0 then /* only severly fatal errors will get here */ call ssu_$abort_line (P_sci_ptr, code, "Parsing control arguments."); if argument_idx <= n_arguments then do; /*** An argument not recognized by the mail system: must be one of ours */ call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-add_comments") | (argument = "-add_comment") then add_comments = "1"b; else if (argument = "-no_add_comments") | (argument = "-no_add_comment") then add_comments = "0"b; else if (argument = "-acknowledge") | (argument = "-ack") then local_do.acknowledge = "1"b; else if (argument = "-no_acknowledge") | (argument = "-nack") then local_do.acknowledge = "0"b; else if (argument = "-brief") | (argument = "-bf") then brief_sw = "1"b; else if (argument = "-long") | (argument = "-lg") then brief_sw = "0"b; else if (argument = "-include_deleted") | (argument = "-idl") then msg_type = ALL_MESSAGES; else if (argument = "-only_deleted") | (argument = "-odl") then msg_type = ONLY_DELETED_MESSAGES; else if (argument = "-only_non_deleted") | (argument = "-ondl") then msg_type = NON_DELETED_MESSAGES; else if (argument = "-notify") | (argument = "-nt") then local_do.recipient_notification = "1"b; else if (argument = "-no_notify") | (argument = "-nnt") then local_do.recipient_notification = "0"b; else if (argument = "-reverse") | (argument = "-rv") then reverse_sw = "1"b; else if (argument = "-no_reverse") | (argument = "-nrv") then reverse_sw = "0"b; else if (argument = "-delete") | (argument = "-dl") then delete_sw = "1"b; else if (argument = "-no_delete") | (argument = "-ndl") then delete_sw = "0"b; else if (argument = "-message") | (argument = "-msg") then do; if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "A message specifier must follow ""^a"".", argument); argument_idx = argument_idx + 1; call process_argument_as_spec (); end; /*** Control arguments related to adding comments ... */ else if (argument = "-terminal_input") | (argument = "-ti") then local_rfso.input_type = TERMINAL_INPUT; else if (argument = "-input_file") | (argument = "-if") then do; call get_next_argument ("A pathname"); local_rfso.input_type = FILE_INPUT; input_filename_ptr = argument_ptr; input_filename_lth = argument_lth; end; /* save it for later processing */ else if (argument = "-fill") | (argument = "-fi") then local_rfso.enable_filling = FILL; else if (argument = "-no_fill") | (argument = "-nfi") then local_rfso.enable_filling = NO_FILL; else if (argument = "-line_length") | (argument = "-ll") then do; call get_next_argument ("A number"); local_rfso.fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "-line_length ""^a""", argument); if local_rfso.fill_width < 21 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 20."); end; /*** Control arguments required by the MCR boards despite the furious objections of the author */ else if argument = "-auto_write" then local_rfso.auto_write = "1"b; else if argument = "-no_auto_write" then local_rfso.auto_write = "0"b; /*** Standard subsystem control arguments */ else if (argument = "-abbrev") | (argument = "-ab") then local_rfso.enable_abbrev, abbrev_ca_given = "1"b; else if (argument = "-no_abbrev") | (argument = "-nab") then do; local_rfso.enable_abbrev = "0"b; abbrev_ca_given = "1"b; end; else if (argument = "-profile") | (argument = "-pf") then do; call get_next_argument ("A pathname"); profile_pathname_given = "1"b; profile_pathname_ptr = argument_ptr; profile_pathname_lth = argument_lth; end; /* save for later processing */ else if (argument = "-prompt") | (argument = "-pmt") then do; call get_next_argument ("A string"); if argument_lth = 0 then /* same as -no_prompt */ local_rfso.enable_prompt = NO_PROMPT; else do; local_rfso.enable_prompt = USE_PROMPT_STRING; local_rfso.prompt_string = argument; end; end; else if (argument = "-no_prompt") | (argument = "-npmt") then local_rfso.enable_prompt = NO_PROMPT; else if (argument = "-request") | (argument = "-rq") then do; call get_next_argument ("A string"); local_rfso.initial_requests_ptr = argument_ptr; local_rfso.initial_requests_lth = argument_lth; end; else if (argument = "-request_loop") | (argument = "-rql") then local_rfso.enter_request_loop = REQUEST_LOOP; else if (argument = "-no_request_loop") | (argument = "-nrql") then local_rfso.enter_request_loop = NO_REQUEST_LOOP; /*** following control arguments are obsolete: remove them in MR11 */ else if (argument = "-all") | (argument = "-a") then msg_type = ALL_MESSAGES; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, error_table_$bad_arg, """^a""", argument); argument_idx = argument_idx + 1; /* skip over argument we processed */ end; end; if is_empty_list (local_ri.forwarding.address_list_ptr) then go to NO_FORWARDING_ADDRESSES; if msg_spec_count = 0 then /* defaults to the current message */ call rdm_message_mark_mgr_$mark_current_message (rdm_invocation_ptr, msg_type); /* phx19099 RL - use of "-odl" with current message will be caught during marking */ else call process_msg_specs (); if add_comments then do; /* Get the user's comment by invoking our sub-subsystem */ call ssu_$get_temp_segment (P_sci_ptr, "comment-buffer", comment_buffer_ptr); if local_rfso.input_type = FILE_INPUT then do; /*** Find the specified input file ... */ call expand_pathname_ (input_filename, input_file_dirname, input_file_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-input_file ""^a""", input_filename); call initiate_file_ (input_file_dirname, input_file_ename, R_ACCESS, local_rfso.input_file_ptr, input_file_bitcount, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-input_file ""^a""", pathname_ (input_file_dirname, input_file_ename)); local_rfso.input_file_lth = divide ((input_file_bitcount + 8), 9, 21, 0); end; if profile_pathname_given then do; /*** Initiate the subsystem profile requested by the user */ call expand_pathname_$add_suffix (profile_pathname, "profile", profile_dirname, profile_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-profile ""^a""", profile_pathname); call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, local_rfso.default_profile_ptr, (0), code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-profile ""^a""", pathname_ (profile_dirname, profile_ename)); if ^abbrev_ca_given then /* -profile implies -abbrev unless explicit -ab/-nab given */ local_rfso.enable_abbrev = "1"b; abbrev_ca_given = "1"b; /* do not copy read_mail's abbreviation processing state */ end; if ^abbrev_ca_given then do; /*** User did not give any abbrev control arguments: use read_mail's state of abbreviation processing */ call ssu_$get_abbrev_info (P_sci_ptr, local_rfso.default_profile_ptr, local_rfso.profile_ptr, local_rfso.enable_abbrev); if local_rfso.default_profile_ptr ^= null () then call add_null_refname (local_rfso.default_profile_ptr); if (local_rfso.profile_ptr ^= null ()) & (local_rfso.profile_ptr ^= local_rfso.default_profile_ptr) then call add_null_refname (local_rfso.profile_ptr); end; /* ssu_ never terminiates same profile twice */ /*** Invoke the subsystem to actually do the work */ call rdm_message_mark_mgr_$mark_original_messages (rdm_invocation_ptr); saved_current_message = rdm_invocation.current_message; clear_original_message_chain = "1"b; call rdm_forward_subsystem_ (rdm_invocation_ptr, addr (local_rfso), addr (comment_buffer), length (comment_buffer), comment_text_lth, code); clear_original_message_chain = "0"b; rdm_invocation.current_message = saved_current_message; call rdm_message_mark_mgr_$clear_original_messages (rdm_invocation_ptr); if code ^= 0 then if code = emf_et_$forwarding_aborted then if brief_sw then call ssu_$abort_line (P_sci_ptr, 0); else call ssu_$abort_line (P_sci_ptr, 0, "No messages forwarded."); else call ssu_$abort_line (P_sci_ptr, code, "Invoking forward sub-subsystem."); end; else do; /* User does not want to add a comment */ comment_buffer_ptr = addr (NULL_STRING); /* prevents faults */ comment_text_lth = 0; end; /* Forward the messages one at a time */ if reverse_sw then do; /* process messages in the reverse of the order marked */ first_message_idx = marked_chain.n_messages; last_message_idx = 1; message_idx_increment = -1; end; else do; /* process messages in the order marked */ first_message_idx = 1; last_message_idx = marked_chain.n_messages; message_idx_increment = 1; end; do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); /* phx18564 RL - set current message to message_number and guarantee that it's not deleted */ call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, message_number, rdm_invocation.current_message); /* each message is current as it's processed */ call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); call mail_system_$redistribute_message (message_ptr, comment_text, addr (local_ri), addr (local_do), code); if (code ^= 0) & (code ^= mlsys_et_$message_not_sent) & (code ^= mlsys_et_$message_partially_sent) then call ssu_$abort_line (P_sci_ptr, code, "Attempting to forward message #^d.", message_number); call mlsys_utils_$print_delivery_results (P_sci_ptr, brief_sw, addr (local_ri), (0)); call mlsys_utils_$free_delivery_results (addr (local_ri), (0)); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Message #^d.", message_number); call rdm_mailbox_interface_$mark_processed_and_acknowledge (rdm_invocation_ptr, message_number); end; /* Clean up */ if delete_sw then /* delete messages if requested */ call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, "0"b); call cleanup_after_forward_request (); return; %page; /* Cleans up after execution of the request */ cleanup_after_forward_request: procedure (); if clear_original_message_chain then do; rdm_invocation.current_message = saved_current_message; call rdm_message_mark_mgr_$clear_original_messages (rdm_invocation_ptr); clear_original_message_chain = "0"b; end; call mlsys_utils_$free_delivery_results (addr (local_ri), (0)); if local_ri.forwarding.address_list_ptr ^= null () then call mail_system_$free_address_list (local_ri.forwarding.address_list_ptr, (0)); if (comment_buffer_ptr ^= null ()) & (comment_buffer_ptr ^= addr (NULL_STRING)) then call ssu_$release_temp_segment (P_sci_ptr, comment_buffer_ptr); if local_rfso.input_file_ptr ^= null () then call terminate_file_ (local_rfso.input_file_ptr, 0, TERM_FILE_TERM, (0)); return; end cleanup_after_forward_request; /* Fetches the value expected after the given control argument */ get_next_argument: procedure (p_argument_type); dcl p_argument_type character (*) parameter; if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "^a after ""^a"".", p_argument_type, argument); argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); return; end get_next_argument; %page; /* Marks the current argument as a message specifier */ process_argument_as_spec: procedure (); if msg_spec_count >= hbound (msg_spec_array, 1) then call ssu_$abort_line (P_sci_ptr, 0, "Too many message specifiers in request."); /* can't ever happen */ msg_spec_count = msg_spec_count + 1; msg_spec_array (msg_spec_count) = argument_idx; return; end process_argument_as_spec; /* Process the message specifiers on the request line */ process_msg_specs: procedure (); dcl idx fixed binary; do idx = 1 to msg_spec_count; call ssu_$arg_ptr (P_sci_ptr, msg_spec_array (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, msg_type, "0"b, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code); end; return; end process_msg_specs; %page; /* Adds a null reference name to the supplied profile: ssu_ will terminate a null refname when the forward sub-subsystem invocation is destroyed but read_mail will still try to reference the profile; adding an extra null refname here makes everything work properly */ add_null_refname: procedure (p_profile_ptr); dcl p_profile_ptr pointer parameter; dcl new_profile_ptr pointer; dcl profile_dirname character (168); dcl profile_ename character (32); call hcs_$fs_get_path_name (p_profile_ptr, profile_dirname, (0), profile_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Copying state of read_mail abbrev processing."); call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, new_profile_ptr, (0), code); if p_profile_ptr ^= new_profile_ptr then call ssu_$abort_line (P_sci_ptr, code, "Copying state of read_mail abbrev processing."); return; end add_null_refname; /* Determines if the supplied address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* nothing there at all */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include rdm_fwd_subsystem_opts; %page; %include mlsys_address_list; %page; %include mlsys_parse_ca_options; %page; %include mlsys_deliver_info; %page; %include access_mode_values; %page; %include terminate_file; end rdm_forward_request_;  rdm_forward_subsystem_.pl1 08/23/84 0834.4rew 08/23/84 0825.6 106515 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* rdm_forward_subsystem_: a mini-subsystem created by read_mail to permit entering and editing a forwarding comment (forward -add_comments). */ /* Written: 4 Oct 1983 by B. Margolin Modified: 8 Aug 1984 by P. Benjamin to change ssu_$standard_requests to ssu_request_tables_$standard_requests. */ /* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */ rdm_forward_subsystem_: proc (P_rdm_invocation_ptr, P_rfso_ptr, P_buffer_ptr, P_buffer_size, P_buffer_used, P_code); /*** Parameters ***/ dcl (P_rdm_invocation_ptr, P_rfso_ptr, P_buffer_ptr) ptr parameter; dcl (P_buffer_size, P_buffer_used) fixed bin (21) parameter; dcl P_code fixed bin (35) parameter; /*** Automatic ***/ dcl action bit (35) aligned; dcl buffer_ptr ptr; dcl buffer_size fixed bin (21); dcl code fixed bin (35); dcl default_prompt char (64) varying; dcl edit_requests_len fixed bin (21); dcl edit_requests_ptr ptr; dcl fatal_error bit (1) aligned; dcl initial_rql_len fixed bin (21); dcl input_terminator_type fixed bin; dcl level fixed bin; dcl 1 rfi aligned like rdm_forward_invocation; dcl rfso_ptr ptr; dcl sci_ptr ptr; /*** Based ***/ dcl buffer char (buffer_size) based (buffer_ptr); dcl edit_requests char (edit_requests_len) based (edit_requests_ptr); dcl 1 rfso aligned like rdm_forward_subsystem_options based (rfso_ptr); dcl user_initial_requests char (rfso.initial_requests_lth) based (rfso.initial_requests_ptr); /*** Entries ***/ dcl cu_$cl entry (bit (36) aligned); dcl ( ioa_$ioa_switch, ioa_$rsnnl ) entry () options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl rdm_fwd_text_mgr_$file_input entry (ptr, ptr, fixed bin (21), bit (1) aligned); dcl rdm_fwd_text_mgr_$terminal_input entry (ptr, fixed bin, ptr, fixed bin (21), bit (1) aligned); dcl requote_string_ entry (char (*)) returns (char (*)); dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35)); dcl ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl ssu_$get_invocation_count entry (ptr, fixed bin, fixed bin); dcl ssu_$get_request_name entry (ptr) returns (char (32)); dcl ssu_$get_subsystem_name entry (ptr) returns (char (32)); dcl ssu_$get_temp_segment entry (ptr, char (*), ptr); dcl ssu_$listen entry (ptr, ptr, fixed bin (35)); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (ptr, ptr); dcl ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned); dcl ssu_$set_ec_search_list entry (ptr, char (32)); dcl ssu_$set_ec_suffix entry (ptr, char (32)); dcl ssu_$set_debug_mode entry (ptr, bit (1) aligned); dcl ssu_$set_prompt entry (ptr, char (64) var); dcl ssu_$set_prompt_mode entry (ptr, bit (*)); dcl sub_err_ entry () options (variable); /*** Static ***/ dcl ( emf_et_$forwarding_aborted, error_table_$unimplemented_version, ssu_et_$subsystem_aborted ) fixed bin (35) ext static; dcl iox_$error_output ptr; dcl ( rdm_request_tables_$forward_requests, ssu_request_tables_$standard_requests ) ext static; /* Data type insignificant */ dcl WHOAMI char (17) int static options (constant) init ("read_mail.forward"); /*** Miscellany ***/ dcl (addwordno, length, min, null, substr) builtin; dcl cleanup condition; %page; %include rdm_data; %page; %include rdm_fwd_invocation; %page; %include rdm_fwd_subsystem_opts; %page; %include rdm_fwd_text_mgr_const; %page; %include rdm_invocation; %page; %include ssu_prompt_modes; %page; %include sub_err_flags; %page; rdm_invocation_ptr = P_rdm_invocation_ptr; rfso_ptr = P_rfso_ptr; buffer_ptr = P_buffer_ptr; buffer_size = P_buffer_size; P_buffer_used, P_code = 0; rfi.temp_seg_ptr, sci_ptr = null (); on cleanup call cleanup_rfs (); if rfso.version ^= RDM_FORWARD_SUBSYSTEM_OPTIONS_VERSION_1 then call abort_rfs (error_table_$unimplemented_version); rfi.type = RDM_FORWARD_INVOCATION; rfi.rfso_ptr = rfso_ptr; rfi.rdm_invocation_ptr = rdm_invocation_ptr; rfi.area_ptr = rdm_invocation.area_ptr; rfi.debug_mode = rdm_invocation.debug_mode; /* Check for a really trivial combination of options */ if rfso.input_type = FILE_INPUT & rfso.enter_request_loop = NO_REQUEST_LOOP & (rfso.enable_filling = DEFAULT_FILL | rfso.enable_filling = NO_FILL) then do; /* Just copy it and return */ rfi.buffer_used = rfso.input_file_lth; rfi.buffer_ptr = rfso.input_file_ptr; call successful_return (addr (rfi)); end; call ssu_$create_invocation (WHOAMI, (rdm_data_$version), addr (rfi), addr (rdm_request_tables_$forward_requests), pathname_ (rdm_data_$info_directory, "forward_requests"), sci_ptr, code); if code ^= 0 then do; if rfi.debug_mode then action = ACTION_CAN_RESTART; else action = ACTION_DEFAULT_RESTART; call sub_err_ (code, WHOAMI, action, null (), (0), "Creating forwarding subsystem invocation."); call unsuccessful_return (); end; call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), 2, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "Adding standard request table. Going on without standard ssu_ requests."); code = 0; rfi.sci_ptr = sci_ptr; call ssu_$set_debug_mode (sci_ptr, (rfi.debug_mode)); call ssu_$get_temp_segment (sci_ptr, "Comment Text", rfi.temp_seg_ptr); if rfi.temp_seg_ptr = null () then call unsuccessful_return (); /* Message already printed by ssu_ */ if rfso.enable_filling = DEFAULT_FILL then rfi.fill = (rfso.input_type = TERMINAL_INPUT); else rfi.fill = (rfso.enable_filling = FILL); rfi.fill_width = rfso.fill_width; if rfso.enter_request_loop = DEFAULT_REQUEST_LOOP then rfi.enter_request_loop = (rfso.input_type = FILE_INPUT); else rfi.enter_request_loop = (rfso.enter_request_loop = REQUEST_LOOP); if rfso.enable_prompt = NO_PROMPT then call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT); else if rfso.enable_prompt = USE_PROMPT_STRING then call ssu_$set_prompt (sci_ptr, rfso.prompt_string); else if rfso.enable_prompt = DEFAULT_PROMPT then do; call ssu_$get_invocation_count (rdm_invocation.sci_ptr, level, (0)); call ioa_$rsnnl ("^^/^a^[ (^d)^;^s^] (^a):^^2x", /* ^^ because we are generating an ioa_ string */ default_prompt, (0), ssu_$get_subsystem_name (rdm_invocation.sci_ptr), (level ^= 1), level, ssu_$get_request_name (rdm_invocation.sci_ptr)); call ssu_$set_prompt (sci_ptr, default_prompt); end; rfi.auto_write = rfso.auto_write; call ssu_$set_abbrev_info (sci_ptr, rfso.default_profile_ptr, rfso.profile_ptr, (rfso.enable_abbrev)); call ssu_$set_ec_search_list (sci_ptr, rdm_data_$ec_search_list); call ssu_$set_ec_suffix (sci_ptr, rdm_data_$ec_suffix); /* Now start playing with the text */ if rfso.input_type = TERMINAL_INPUT then call rdm_fwd_text_mgr_$terminal_input (addr (rfi), input_terminator_type, edit_requests_ptr, edit_requests_len, fatal_error); else /*** if rfso.input_type = FILE_INPUT then ***/ do; call rdm_fwd_text_mgr_$file_input (addr (rfi), rfso.input_file_ptr, rfso.input_file_lth, fatal_error); input_terminator_type = NORMAL_TERMINATION; edit_requests_len = 0; end; if fatal_error then call unsuccessful_return (); /*** Build the initial request line ***/ initial_rql_len = rfso.initial_requests_lth; /* -request */ if edit_requests_len > 0 then /* said \f */ initial_rql_len = initial_rql_len + length ("qedx -request """"; ") + 2 * edit_requests_len; /* room for requoting */ else if input_terminator_type = ENTER_EDITOR then /* said \f */ initial_rql_len = initial_rql_len + length ("qedx; "); if rfi.fill then initial_rql_len = initial_rql_len + length ("fill; "); initial_rql_len = initial_rql_len + length ("send"); /* Just in case, leave room */ initial_request: begin; dcl initial_rql char (initial_rql_len) varying; if ^rfi.enter_request_loop /* No explicit -rql */ & (rfso.initial_requests_lth = 0) /* or -request */ & (input_terminator_type = NORMAL_TERMINATION) then /* Just typed . */ if rfi.fill then initial_rql = "fill; send"; else initial_rql = "send"; else do; initial_rql = ""; if input_terminator_type = ENTER_EDITOR then /* \f */ if edit_requests_len = 0 then initial_rql = "qedx; "; else do; initial_rql = "qedx -request " || requote_string_ (edit_requests); initial_rql = initial_rql || "; "; end; if rfi.fill then initial_rql = initial_rql || "fill; "; if rfso.initial_requests_lth > 0 then initial_rql = initial_rql || user_initial_requests; end; if length (initial_rql) > 0 then do; call ssu_$execute_line (sci_ptr, addwordno (addr (initial_rql), 1), length (initial_rql), code); if code = ssu_et_$subsystem_aborted then go to SUBSYS_ABORTED; end; end initial_request; /*** Finally, we get to the real work! ***/ call ssu_$listen (sci_ptr, null (), code); if code ^= 0 then if code = ssu_et_$subsystem_aborted then SUBSYS_ABORTED: if rfi.abort_code = 0 then call successful_return (addr (rfi)); /* send */ else if rfi.abort_code = emf_et_$forwarding_aborted then call unsuccessful_return (); /* quit */ else call abort_rfs (rfi.abort_code); /* some other error */ else do; /* can't call ssu_$abort_subsystem from outside a listener or request line */ call ssu_$print_message (sci_ptr, code, "Invoking the sub-request-loop listener."); if rfi.debug_mode then do; /* simulate ssu_$abort_subsystem */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; call cu_$cl."); call cu_$cl (""b); end; call unsuccessful_return (); end; call successful_return (addr (rfi)); GLOBAL_RETURN: call cleanup_rfs (); return; %page; /**** Abort the subsystem, returning the specified code ****/ abort_rfs: proc (P_abort_code); dcl P_abort_code fixed bin (35); P_code = P_abort_code; go to GLOBAL_RETURN; end abort_rfs; /**** Normal return, set the output parameters ****/ successful_return: proc (P_rfi_ptr); dcl P_rfi_ptr ptr parameter; dcl 1 local_rfi aligned like rdm_forward_invocation based (P_rfi_ptr); dcl rfi_buffer char (local_rfi.buffer_used) based (local_rfi.buffer_ptr); P_buffer_used = min (local_rfi.buffer_used, buffer_size); substr (buffer, 1, P_buffer_used) = substr (rfi_buffer, 1, P_buffer_used); P_code = 0; go to GLOBAL_RETURN; end successful_return; /**** Normal return when the message shouldn't be forwarded (e.g. quit) ****/ unsuccessful_return: proc (); P_code = emf_et_$forwarding_aborted; go to GLOBAL_RETURN; end unsuccessful_return; cleanup_rfs: proc (); if rfi.temp_seg_ptr ^= null then call ssu_$release_temp_segment (sci_ptr, rfi.temp_seg_ptr); if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end cleanup_rfs; end rdm_forward_subsystem_;  rdm_fwd_debug_requests_.pl1 10/27/83 1707.1rew 10/27/83 1104.0 30006 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ /* Debugging requests for the read_mail forwarding sub-request-loop */ /* Created: October 1983 by B. Margolin (from sdm_debug_requests_) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_fwd_debug_requests_: procedure (P_sci_ptr, P_rdm_forward_invocation_ptr); put file (rdm_fwd_debug_) data; /* forces a full symbol table ... */ return; /* ... but not really an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_rdm_forward_invocation_ptr pointer parameter; dcl sci_ptr pointer; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl new_debug_mode bit (1) aligned; dcl code fixed binary (35); dcl rdm_fwd_debug_ file stream internal; dcl buffer char (rdm_forward_invocation.buffer_used) based (rdm_forward_invocation.buffer_ptr); dcl error_table_$bad_arg fixed binary (35) external; dcl error_table_$badopt fixed binary (35) external; dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$set_debug_mode entry (pointer, bit (1) aligned); dcl probe entry () options (variable); dcl index builtin; %page; /* The "debug_mode" request: enables/disables send_mail debugging facilities */ debug_mode: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); sci_ptr = P_sci_ptr; rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; new_debug_mode = "1"b; /* defaults to turn on debug_mode */ call ssu_$arg_count (sci_ptr, n_arguments); do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if argument = "-on" then new_debug_mode = "1"b; else if argument = "-off" then new_debug_mode = "0"b; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "This request only accepts control arguments. ""^a""", argument); end; rdm_forward_invocation.debug_mode = new_debug_mode; call ssu_$set_debug_mode (sci_ptr, (rdm_forward_invocation.debug_mode)); /* keep ssu_ in step */ return; %page; /* The "probe" request: invokes the probe symbolic debugger in a stack frame with all relavent data structure available */ probe: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); sci_ptr = P_sci_ptr; rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; call ssu_$arg_count (sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (sci_ptr, 0, "No arguments may be supplied."); call probe (); return; %page; /* Several include files just so that you can examine things */ %include rdm_fwd_invocation; %page; %include rdm_fwd_subsystem_opts; %page; %include rdm_invocation; end rdm_fwd_debug_requests_;  rdm_fwd_misc_requests_.pl1 10/27/83 1707.2rew 10/27/83 1104.0 30042 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ /* Miscellaneous forward sub-requests */ /* Created: October 1983 by B. Margolin (from sdm_misc_requests_) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_fwd_misc_requests_: procedure (P_sci_ptr, P_rdm_forward_invocation_ptr); return; /* not an entry */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_rdm_forward_invocation_ptr pointer parameter; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl request_name character (72); dcl force bit (1); /* format: off */ dcl (error_table_$bad_arg, error_table_$badopt, emf_et_$forwarding_aborted) fixed binary (35) external; /* format: on */ dcl command_query_$yes_no entry () options (variable); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl index builtin; %page; /* The "send" request: exits forwarding sub-request-loop, sending the message. */ send_request: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; rdm_forward_invocation.abort_code = 0; call ssu_$abort_subsystem (P_sci_ptr, 0); /* Never returns */ %page; /* The "quit" request: exits forwarding sub-request-loop without sending the message. The user is queried for permission to exit. */ quit_request: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; request_name = ssu_$get_subsystem_and_request_name (P_sci_ptr); call ssu_$arg_count (P_sci_ptr, n_arguments); rdm_forward_invocation.abort_code = 0; /* assume message was processed before exit */ force = "0"b; /* ask user by default */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then if (argument = "-force") | (argument = "-fc") then force = "1"b; else if (argument = "-no_force") | (argument = "-nfc") then force = "0"b; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, "^a", argument); else call ssu_$abort_line (P_sci_ptr, error_table_$bad_arg, "This request only accepts control arugments.") ; end; if ^force then /* ... need the user's permission */ call command_query_$yes_no (force, 0, request_name, "", "The forwarded message has not been sent.^/Do you still wish to quit?"); if ^force then call ssu_$abort_line (P_sci_ptr, 0); rdm_forward_invocation.abort_code = emf_et_$forwarding_aborted; call ssu_$abort_subsystem (P_sci_ptr, 0); /* never returns */ %page; %include rdm_fwd_invocation; end rdm_fwd_misc_requests_;  rdm_fwd_text_mgr_.pl1 11/01/84 1443.8r w 11/01/84 1304.2 103365 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */ rdm_fwd_text_mgr_: proc (); /* entrypoints for manipulating the text of a read_mail forwarding comment */ /* Written 7 October 1983 by B. Margolin */ /*** Common Parameters ***/ dcl P_rfi_ptr pointer parameter; dcl P_fatal_error bit (1) aligned parameter; /* set ON => an unrecoverable error occured */ /*** terminal_input Parameters ***/ dcl P_input_terminator_type fixed binary parameter; /* set to type of termination (normal/request-loop/qedx) */ dcl P_edit_requests_ptr pointer parameter; /* set -> editor requests input by user (if any) */ dcl P_edit_requests_lth fixed binary (21) parameter; /* set to length of the editor requests */ /*** file_input Parameters ***/ dcl P_input_file_ptr ptr parameter; /* -> user-specified input file */ dcl P_input_file_len fixed bin (21) parameter; /* length of input file */ /*** fill_text Parameters ***/ dcl P_fill_width fixed binary parameter; /* width to use for formatting the text */ /*** Automatic ***/ dcl code fixed bin (35); dcl edit_requests_lth fixed bin (21); dcl edit_requests_ptr ptr; dcl fdoc_buffer_ptr ptr; dcl fdoc_text_lth fixed bin (21); dcl idx fixed bin (21); dcl input_line_lth fixed bin (21); dcl last_character_of_sequence fixed bin (21); dcl 1 local_fdo aligned like format_document_options; dcl original_buffer_ptr ptr; dcl original_text_lth fixed bin (21); dcl rfi_ptr ptr; dcl terminator_type fixed bin; dcl the_character char (1); /*** Based ***/ dcl edit_requests char (edit_requests_lth) based (edit_requests_ptr); dcl fdoc_buffer char (4 * sys_info$max_seg_size) based (fdoc_buffer_ptr); dcl original_buffer char (4 * sys_info$max_seg_size) based (original_buffer_ptr); dcl original_text char (original_text_lth) based (original_buffer_ptr); dcl rdm_fwd_area area based (rfi.area_ptr); dcl 1 rfi aligned like rdm_forward_invocation based (rfi_ptr); /*** Entries ***/ dcl cu_$arg_list_ptr entry () returns (ptr); dcl cu_$cl entry (bit (36) aligned); dcl cu_$generate_call entry (entry, ptr); dcl format_document_$string entry (char (*), char (*), fixed bin (21), ptr, fixed bin (35)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl ssu_$get_temp_segment entry (ptr, char (*), ptr); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (ptr, ptr); /*** Static ***/ dcl error_table_$recoverable_error fixed bin (35) ext static; dcl ( iox_$error_output, iox_$user_input ) ptr ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /*** Misc ***/ dcl (cleanup, program_interrupt) condition; %page; %include format_document_options; %page; %include rdm_fwd_invocation; %page; %include rdm_fwd_text_mgr_const; %page; /*^ Reads the text of the message from the terminal: the possible terminators for the text are: '.' end of input '\fq' end of input, enter request loop, and '\f...' end of input, enter editor with given requests (if any) */ terminal_input: entry (P_rfi_ptr, P_input_terminator_type, P_edit_requests_ptr, P_edit_requests_lth, P_fatal_error); rfi_ptr = P_rfi_ptr; original_text_lth = 0; /* nothing read yet */ edit_requests_lth = 0; /* no editor requests yet */ on condition (program_interrupt) begin; /* stop reading if the user asks us ... */ terminator_type = ENTER_REQUEST_LOOP; go to END_OF_INPUT; end; call ioa_ ("Comment:"); /*** Message reading loop ... ***/ terminator_type = 0; /* really need do until ... */ input_line_lth = 0; original_buffer_ptr = rfi.temp_seg_ptr; do while (terminator_type = 0); original_text_lth = original_text_lth + input_line_lth; begin; dcl rest_of_original_buffer character (length (original_buffer) - original_text_lth) unaligned defined (original_buffer) position (original_text_lth + 1); call iox_$get_line (iox_$user_input, addr (rest_of_original_buffer), length (rest_of_original_buffer), input_line_lth, code); if code ^= 0 then /* ... all errors fatal when an entire segment available */ call abort_terminal_input (rfi.sci_ptr, code, "Reading the message text."); /*** ... Search for terminators ***/ begin; dcl input_line character (input_line_lth) unaligned defined (original_buffer) position (original_text_lth + 1); if input_line_lth = 2 then if substr (input_line, 1, 1) = "." then terminator_type = NORMAL_TERMINATION; else ; else do; /* look for escape (\) sequences */ idx = index (input_line, "\"); do while (idx ^= 0); /* ... while there are \'s in line */ original_text_lth = original_text_lth + idx - 1; /* ... include everything before the \ in the text */ input_line_lth = input_line_lth - idx + 1; begin; dcl input_line character (input_line_lth) unaligned defined (original_buffer) position (original_text_lth + 1); if input_line_lth >= 2 then do; /* ... stuff after \ on line */ the_character = substr (input_line, 2, 1); if the_character = "f" then do; /*** \f...: terminates input and maybe enters the editor */ if input_line_lth >= 3 then if substr (input_line, 3, 1) = "q" then do; /* ... special case \fq to go straight to request loop */ last_character_of_sequence = 3; go to PROCESS_ENTER_REQUEST_LOOP_ESCAPE; end; terminator_type = ENTER_EDITOR; if input_line_lth >= 4 then do; /* ... if anything after \f and before NL */ edit_requests_lth = input_line_lth - 3; allocate edit_requests in (rdm_fwd_area) set (edit_requests_ptr); edit_requests = substr (input_line, 3, edit_requests_lth); end; end; else if the_character = "q" then do; /*** \q or \fq: enter request loop */ last_character_of_sequence = 2; PROCESS_ENTER_REQUEST_LOOP_ESCAPE: terminator_type = ENTER_REQUEST_LOOP; if input_line_lth >= (last_character_of_sequence + 2) then call ssu_$print_message (rfi.sci_ptr, code, "Text after ""^a"" ignored.", substr (input_line, 1, last_character_of_sequence)); end; else if the_character = "c" then do; /*** \c: escape the next character */ substr (input_line, 1, input_line_lth - 2) = substr (input_line, 3); original_text_lth = original_text_lth + 1; input_line_lth = input_line_lth - 3; end; else do; /*** unknown: take it literally */ original_text_lth = original_text_lth + 1; input_line_lth = input_line_lth - 1; end; end; end; begin; dcl input_line character (input_line_lth) unaligned defined (original_buffer) position (original_text_lth + 1); if terminator_type = 0 then idx = index (input_line, "\"); else idx = 0; end; end; end; end; end; end; /*** We have the comment text now ***/ END_OF_INPUT: rfi.buffer_ptr = original_buffer_ptr; rfi.buffer_used = original_text_lth; P_input_terminator_type = terminator_type; /* tell the caller what to do next */ if edit_requests_lth ^= 0 then /* there are some editing requests */ P_edit_requests_ptr = edit_requests_ptr; else P_edit_requests_ptr = null (); P_edit_requests_lth = edit_requests_lth; P_fatal_error = "0"b; /* success */ RETURN_FROM_TERMINAL_INPUT: return; %page; /* Reads the text of the message from the specified segment */ file_input: entry (P_rfi_ptr, P_input_file_ptr, P_input_file_len, P_fatal_error); rfi_ptr = P_rfi_ptr; rfi.buffer_ptr = P_input_file_ptr; rfi.buffer_used = P_input_file_len; P_fatal_error = "0"b; /* success */ return; %page; /* Reformats the message body text using format_document_ with fill-on and align-left modes */ fill_text: entry (P_rfi_ptr, P_fill_width, P_fatal_error); rfi_ptr = P_rfi_ptr; fdoc_buffer_ptr = null (); /* for cleanup handler */ on condition (cleanup) call release_fill_buffer (); call ssu_$get_temp_segment (rfi.sci_ptr, "fdoc-text", fdoc_buffer_ptr); if fdoc_buffer_ptr = null () then call abort_fill_text (); original_buffer_ptr = rfi.buffer_ptr; original_text_lth = rfi.buffer_used; /*** Setup format_document_ options */ local_fdo.version_number = format_document_version_2; local_fdo.indentation = 0; local_fdo.line_length = P_fill_width; /* ... let caller control the width */ string (local_fdo.switches) = ""b; local_fdo.galley_sw = "1"b; /* ... don't insert page breaks */ local_fdo.literal_sw = "1"b; /* ... don't recognize controls in the text */ local_fdo.dont_compress_sw = "1"b; /* ... don't compress whitespace */ local_fdo.dont_break_indented_lines_sw = "1"b; /* ... don't break lines which are indented */ local_fdo.syllable_size = 0; call format_document_$string (original_text, fdoc_buffer, fdoc_text_lth, addr (local_fdo), code); if code = error_table_$recoverable_error then code = 0; if code ^= 0 then call abort_fill_text (rfi.sci_ptr, code, "Attempting to reformat the message text."); /*** Swap temp-seg ptrs ***/ rfi.buffer_ptr = fdoc_buffer_ptr; fdoc_buffer_ptr = rfi.sci_ptr; /* for release_fill_buffer */ rfi.temp_seg_ptr = rfi.buffer_ptr; rfi.buffer_used = fdoc_text_lth; P_fatal_error = "0"b; /* success */ RETURN_FROM_FILL_TEXT: call release_fill_buffer (); return; %page; /* Releases the buffer used by the fill operation */ release_fill_buffer: procedure (); if fdoc_buffer_ptr ^= null () then call ssu_$release_temp_segment (rfi.sci_ptr, fdoc_buffer_ptr); return; end release_fill_buffer; /* Prints an error message and aborts execution of the current text manager operation */ abort_fill_text: procedure () options (variable); call error (RETURN_FROM_FILL_TEXT, cu_$arg_list_ptr ()); abort_terminal_input: entry () options (variable); call error (RETURN_FROM_TERMINAL_INPUT, cu_$arg_list_ptr ()); error: proc (P_return_label, P_alp); dcl P_alp ptr parameter; /* arg list ptr */ dcl P_return_label label variable parameter; call cu_$generate_call (ssu_$print_message, P_alp); if rfi.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; call fatal_error (P_return_label); end error; end abort_fill_text; fatal_error: proc (P_return_label); dcl P_return_label label variable parameter; P_fatal_error = "1"b; /* informs caller that we've already printed the message */ go to P_return_label; end fatal_error; end rdm_fwd_text_mgr_;  rdm_fwd_text_requests_.pl1 10/27/83 1707.2rew 10/27/83 1104.2 116028 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ /* read_mail forwarding sub-requests which manipulate the comment text */ /* Created: October 1983 by B. Margolin (from sdm_message_requests_) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_fwd_text_requests_: procedure (P_sci_ptr, P_rdm_forward_invocation_ptr); return; /* not an entry */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_rdm_forward_invocation_ptr pointer parameter; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl request_line character (request_line_lth) unaligned based (request_line_ptr); dcl request_line_ptr pointer; dcl request_line_lth fixed binary (21); dcl 1 local_qi aligned, /* data structure for invoking qedx_ */ 2 header like qedx_info.header, 2 buffers (2) like qedx_info.buffers; /* ... buffers 0 and (maybe) exec */ dcl fatal_error bit (1) aligned; /* set ON by rdm_fwd_text_mgr_$fill_text when necessary */ dcl code fixed binary (35); dcl fill bit (1) aligned; /* ON => fill the message after editing */ dcl auto_write bit (1) aligned; /* ON => enable auto-writing in qedx (sigh) */ dcl first_command_argument_idx fixed binary; /* where command line starts in the apply request */ dcl fill_width fixed binary; dcl text_buffer char (rdm_forward_invocation.buffer_used) based (rdm_forward_invocation.buffer_ptr); dcl temp_seg char (rdm_forward_invocation.buffer_used) based (rdm_forward_invocation.temp_seg_ptr); dcl sys_info$max_seg_size fixed binary (19) external; dcl iox_$user_output pointer external; /* format: off */ dcl (error_table_$bad_conversion, error_table_$badopt, error_table_$fatal_error, error_table_$noarg) fixed binary (35) external; /* format: on */ dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl qedx_ entry (pointer, fixed binary (35)); dcl rdm_fwd_text_mgr_$fill_text entry (pointer, fixed binary, bit (1) aligned); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$apply_request_util entry (pointer, fixed binary, pointer, fixed binary (21), fixed binary (21)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$print_message entry () options (variable); dcl (addr, clock, index, length, null, string, unspec) builtin; %page; /* The "print" request: prints the comment text */ print_request: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (P_sci_ptr, 0, "Usage: print"); call iox_$put_chars (iox_$user_output, rdm_forward_invocation.buffer_ptr, rdm_forward_invocation.buffer_used, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the comment text."); return; %page; /* The "qedx" request: invokes the qedx editor on the comment text */ qedx_request: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); fill_width = rdm_forward_invocation.fill_width; /* set default width */ fill = rdm_forward_invocation.fill; /* use global fill specification */ auto_write = rdm_forward_invocation.auto_write; /* use global auto-write specification (sigh) */ request_line_lth = 0; /* no -request */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control agument */ /*** ... these first two control arguments are bought to you by the MCR boards (sigh) */ if argument = "-auto_write" then auto_write = "1"b; else if argument = "-no_auto_write" then auto_write = "0"b; else if (argument = "-fill") | (argument = "-fi") then fill = "1"b; else if (argument = "-no_fill") | (argument = "-nfi") then fill = "0"b; else if (argument = "-line_length") | (argument = "-ll") then if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Number after ""-line_length""."); else do; /* user supplied fill width */ argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "", "-line_length ^a", argument); if fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else if (argument = "-request") | (argument = "-rq") then do; if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "String after ""-request""."); argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); request_line_ptr = addr (argument); request_line_lth = length (argument); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, 0, "Usage: qedx {-control_args}"); end; if rdm_forward_invocation.buffer_ptr ^= rdm_forward_invocation.temp_seg_ptr then do; /* points at -input_file */ temp_seg = text_buffer; rdm_forward_invocation.buffer_ptr = rdm_forward_invocation.temp_seg_ptr; end; local_qi.header.version = QEDX_INFO_VERSION_1; local_qi.editor_name = ssu_$get_subsystem_and_request_name (sci_ptr); string (local_qi.header.flags) = ""b; local_qi.header.query_if_modified = "1"b; /* can't exit without writing */ local_qi.n_buffers = 1; /* start with just the comment text buffer */ local_qi.buffers (1).buffer_name = "0"; /* it's buffer 0 (the default one) */ local_qi.buffers (1).buffer_pathname = ""; local_qi.buffers (1).region_ptr = rdm_forward_invocation.buffer_ptr; local_qi.buffers (1).region_max_lth = 4 * sys_info$max_seg_size; local_qi.buffers (1).region_initial_lth = rdm_forward_invocation.buffer_used; string (local_qi.buffers (1).flags) = ""b; local_qi.buffers (1).read_write_region, /* ... straight into/out of our temporary segment */ local_qi.buffers (1).locked_pathname, local_qi.buffers (1).default_read_ok, local_qi.buffers (1).default_write_ok = "1"b; local_qi.buffers (1).auto_write = auto_write; /* ... sigh */ if request_line_lth > 0 then do; /* need an "exec" buffer for the requests */ local_qi.n_buffers = 2; /* ... obviously */ local_qi.buffers (2).buffer_name = "exec"; local_qi.buffers (2).buffer_pathname = ""; /* ... doesn't come from anywhere */ local_qi.buffers (2).region_ptr = request_line_ptr; local_qi.buffers (2).region_max_lth, local_qi.buffers (2).region_initial_lth = request_line_lth; string (local_qi.buffers (2).flags) = ""b; local_qi.buffers (2).read_write_region, local_qi.buffers (2).execute_buffer, local_qi.buffers (2).locked_pathname = "1"b; end; call qedx_ (addr (local_qi), code); if code = error_table_$fatal_error then /* couldn't initialize: message already printed... */ call ssu_$abort_line (P_sci_ptr, 0); rdm_forward_invocation.buffer_used = local_qi.buffers (1).region_final_lth; /* get length of the buffer after editing */ if fill then do; /* refill it */ call rdm_fwd_text_mgr_$fill_text (rdm_forward_invocation_ptr, fill_width, fatal_error); if fatal_error then call ssu_$abort_line (P_sci_ptr, 0); end; /* ... fill_text will print appropriate messages */ return; %page; /* The "apply" request: applies an arbitrary Multics command line to a temporary segment containing the comment text and updates the comment with the contents of the segment upon completion of the command line. This request can be used to invoke editors other than qedx (eg: Emacs) on the comment */ apply_request: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments = 0 then call ssu_$abort_line (P_sci_ptr, 0, "Usage: apply {-control_args} command-line"); fill_width = rdm_forward_invocation.fill_width; /* set default width */ fill = rdm_forward_invocation.fill; /* defaults to global fill specification */ first_command_argument_idx = 0; /* haven't found the start of the command line yet */ do argument_idx = 1 to n_arguments /* look for control arguments ... */ while (first_command_argument_idx = 0); /* ... until the start of the command line */ call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-fill") | (argument = "-fi") then fill = "1"b; else if (argument = "-no_fill") | (argument = "-nfi") then fill = "0"b; else if (argument = "-line_length") | (argument = "-ll") then if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Number after ""-line_length""."); else do; /* user supplied fill width */ argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "", "-line_length ^a", argument); if fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else first_command_argument_idx = argument_idx; end; /* command line starts here */ if first_command_argument_idx = 0 then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Multics command line."); if rdm_forward_invocation.buffer_ptr ^= rdm_forward_invocation.temp_seg_ptr then do; /* points at -input_file */ temp_seg = text_buffer; rdm_forward_invocation.buffer_ptr = rdm_forward_invocation.temp_seg_ptr; end; call ssu_$apply_request_util (P_sci_ptr, first_command_argument_idx, rdm_forward_invocation.buffer_ptr, rdm_forward_invocation.buffer_used, rdm_forward_invocation.buffer_used); /* call ssu_ to construct and execute the command line */ if fill then do; /* refill it */ call rdm_fwd_text_mgr_$fill_text (rdm_forward_invocation_ptr, fill_width, fatal_error); if fatal_error then call ssu_$abort_line (P_sci_ptr, 0); end; return; %page; /* The "fill" request: reformats the comment text using format_document_ with fill-on and align-left modes */ fill_request: entry (P_sci_ptr, P_rdm_forward_invocation_ptr); rdm_forward_invocation_ptr = P_rdm_forward_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); fill_width = rdm_forward_invocation.fill_width; /* set default width */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-line_length") | (argument = "-ll") then if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Number after ""-line_length""."); else do; /* user supplied fill width */ argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "", "-line_length ^a", argument); if fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, 0, "Usage: fill {-control_args}"); end; call rdm_fwd_text_mgr_$fill_text (rdm_forward_invocation_ptr, fill_width, fatal_error); if fatal_error then call ssu_$abort_line (P_sci_ptr, 0); return; %page; %include rdm_fwd_invocation; %page; %include qedx_info; end rdm_fwd_text_requests_;  rdm_mailbox_interface_.pl1 10/02/89 0908.5rew 10/02/89 0815.0 261738 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - added entry set_new_current_msg to be used for updating the current message; it will guarantee the new current message is not a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* Interface between the read_mail subsystem and the mail_system_ mailbox manager */ /* Created: September 1983 by G. Palter */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen,^indcomtxt */ rdm_mailbox_interface_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_rdm_invocation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; /* open_mailbox, read_message */ dcl P_mailbox_dirname character (*) parameter; /* open_mailbox: absolute pathname of the directory containing the mailbox */ dcl P_mailbox_ename character (*) parameter; /* open_mailbox: entryname of the mailbox */ dcl P_open_options_ptr pointer parameter; /* open_mailbox: -> structure containing options for mail system to use when opening the mailbox */ dcl P_announce_new_messages bit (1) aligned parameter; /* read_new_messages: ON => announce how many new messages were read from the mailbox */ dcl P_n_new_messages fixed binary parameter; /* read_new_messages: set to the number of new messages read from the mailbox */ dcl P_message_number fixed binary parameter; /* read_message: read_mail message number for the message to be read from the mailbox; mark_processed, mark_processed_and_acknowledge: read_mail message number of message to be marked as processed (and acknowledged) */ dcl P_message_ptr pointer parameter; /* read_message: set -> the message structure as read from the mailbox */ dcl P_delete_force bit (1) aligned parameter; /* delete_messages: ON => delete unprocessed messages without asking for permission and ignore access errors */ dcl P_error_during_expunge bit (1) aligned parameter; /* expunge_messages: set ON => an error occured while trying to expunge messages in the mailbox */ dcl P_old_current_msg fixed binary parameter; /* set_new_current_msg: specifies the message number which the new current message must equal or exceed */ dcl P_new_current_msg fixed binary parameter; /* set_new_current_msg: the new current message (a non-deleted message) passed back */ /**** format: indcomtxt */ /* Local copies of parameters */ dcl n_new_messages fixed binary; dcl message_number fixed binary; dcl code fixed binary (35); /* Remaining declarations */ dcl 1 mdl aligned based (mdl_ptr), 2 n_messages fixed binary, 2 messages (mdl_n_messages refer (mdl.n_messages)), /* list of messages in the mailbox ... */ 3 message_number fixed binary, /* ... giving their read_mail message number */ 3 expunged bit (1) aligned; /* ... and whether or not they were just expunged */ dcl mdl_ptr pointer; dcl mdl_n_messages fixed binary; dcl new_message_list_ptr pointer; dcl (first_new_message_number, first_new_message_mailbox_idx) fixed binary; dcl ok_to_delete bit (1); /* command_query_$yes_no should've used aligned... */ dcl last_deleted_message fixed binary; dcl (message_idx, idx) fixed binary; dcl n_previously_expunged fixed binary; dcl iox_$error_output pointer external; /* format: off */ dcl (emf_et_$expunged_message, error_table_$bad_index, mlsys_et_$all_messages_deleted, mlsys_et_$cant_be_deleted, mlsys_et_$no_more_messages, mlsys_et_$some_messages_not_deleted) fixed binary (35) external; /* format: on */ dcl command_query_$yes_no entry () options (variable); dcl continue_to_signal_ entry (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$cl entry (bit (36) aligned); dcl cu_$generate_call entry (entry, pointer); dcl find_condition_info_ entry (pointer, pointer, fixed binary (35)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl mail_system_$acknowledge_message entry (pointer, fixed binary (35)); dcl mail_system_$expunge_messages entry (pointer, fixed binary (35)); dcl mail_system_$mark_message_for_deletion entry (pointer, fixed binary (35)); dcl mail_system_$open_mailbox entry (character (*), character (*), pointer, character (8), pointer, fixed binary (35)); dcl mail_system_$read_message entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$read_new_messages entry (pointer, fixed binary, fixed binary, fixed binary, fixed binary (35)); dcl mail_system_$unmark_message_for_deletion entry (pointer, fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$print_message entry () options (variable); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl sub_error_ condition; dcl (addr, length, min, null, string) builtin; %page; /* Open the specified mailbox and initialize its message chains */ open_mailbox: entry (P_rdm_invocation_ptr, P_mailbox_dirname, P_mailbox_ename, P_open_options_ptr, P_code); rdm_invocation_ptr = P_rdm_invocation_ptr; call mail_system_$open_mailbox (P_mailbox_dirname, P_mailbox_ename, P_open_options_ptr, MAILBOX_VERSION_2, rdm_invocation.mailbox_ptr, P_code); if P_code ^= 0 then return; mailbox_ptr = rdm_invocation.mailbox_ptr; message_list_n_messages = mailbox.n_messages; allocate message_list in (rdm_area) set (rdm_invocation.message_list_ptr); do idx = 1 to message_list.n_messages; /* start with the read_mail message numbers ... */ message_list.messages (idx).message_idx = idx; /* ... being identical to the mail system's */ string (message_list.messages (idx).flags) = ""b; message_list.messages (idx).search_text_ptr = null (); message_list.messages (idx).search_text_lth = 0; end; allocate all_chain in (rdm_area) set (rdm_invocation.message_chains.all); all_chain.n_messages = message_list.n_messages; /* no expunged messages yet */ do idx = 1 to all_chain.n_messages; all_chain.messages (idx) = idx; end; allocate undeleted_chain in (rdm_area) set (rdm_invocation.message_chains.undeleted); undeleted_chain.n_messages = message_list.n_messages; do idx = 1 to undeleted_chain.n_messages; /* no messages have been marked for deletion */ undeleted_chain.messages (idx) = idx; end; allocate deleted_chain in (rdm_area) set (rdm_invocation.message_chains.deleted); deleted_chain.n_messages = 0; /* no messages have been marked for deletion */ allocate marked_chain in (rdm_area) set (rdm_invocation.message_chains.marked); marked_chain.n_messages = 0; /* haven't marked any messages yet */ allocate marked_as_original_chain in (rdm_area) set (rdm_invocation.message_chains.marked_as_original); marked_as_original_chain.n_messages = 0; /* haven't had a reply/forward request yet */ rdm_invocation.current_message = min (1, all_chain.n_messages); /* by definition the first message read is now current */ P_code = 0; /* success */ return; %page; /* Read any recently arrived messages from the mailbox and update all message chains appropriately */ read_new_messages: entry (P_rdm_invocation_ptr, P_announce_new_messages, P_n_new_messages); rdm_invocation_ptr = P_rdm_invocation_ptr; mailbox_ptr = rdm_invocation.mailbox_ptr; first_new_message_number = message_list.n_messages + 1; /* compute message number of first new message (if any) */ first_new_message_mailbox_idx = mailbox.n_messages + 1; /* they appear after last one presently in the mailbox */ /* Read and announce the new messages (if any) */ call mail_system_$read_new_messages (mailbox_ptr, n_new_messages, (0), (0), code); if (code ^= 0) & (code ^= mlsys_et_$no_more_messages) then call abort_read_new_messages (rdm_invocation.sci_ptr, code, "Unable to check for new messages in ^a.", rdm_invocation.mailbox_name); rdm_invocation.mailbox_ptr = mailbox_ptr; /* may have been changed */ P_n_new_messages = n_new_messages; /* let the caller know */ if n_new_messages = 0 then return; /* nothing to do */ if P_announce_new_messages then /* tell the user ... */ if n_new_messages = 1 then call ioa_ ("A new message has arrived."); else call ioa_ ("^d new messages have arrived.", n_new_messages); /* Add the necessary slots to the end of read_mail's message_list */ message_list_n_messages = message_list.n_messages + n_new_messages; allocate message_list in (rdm_area) set (new_message_list_ptr); do idx = 1 to message_list.n_messages; /* copy the old list */ new_message_list_ptr -> message_list.messages (idx) = message_list.messages (idx); end; do idx = 1 to n_new_messages; /* add data for the new messages */ message_number = first_new_message_number + (idx - 1); new_message_list_ptr -> message_list.messages (message_number).message_idx = first_new_message_mailbox_idx + (idx - 1); string (new_message_list_ptr -> message_list.messages (message_number).flags) = ""b; new_message_list_ptr -> message_list.messages (message_number).search_text_ptr = null (); new_message_list_ptr -> message_list.messages (message_number).search_text_lth = 0; end; rdm_invocation.message_list_ptr = new_message_list_ptr; /* Update the message chains */ call grow_message_chain (rdm_invocation.message_chains.all); do idx = 1 to n_new_messages; /* they're in the "all" chain, of course */ all_chain.messages (all_chain.n_messages + idx) = first_new_message_number + (idx - 1); end; all_chain.n_messages = all_chain.n_messages + n_new_messages; call grow_message_chain (rdm_invocation.message_chains.undeleted); do idx = 1 to n_new_messages; /* ... and they haven't been deleted yet */ undeleted_chain.messages (undeleted_chain.n_messages + idx) = first_new_message_number + (idx - 1); end; undeleted_chain.n_messages = undeleted_chain.n_messages + n_new_messages; call grow_message_chain (rdm_invocation.message_chains.deleted); call grow_message_chain (rdm_invocation.message_chains.marked); call grow_message_chain (rdm_invocation.message_chains.marked_as_original); if rdm_invocation.current_message = 0 then /* no current message: first one read becomes current ... */ rdm_invocation.current_message = first_new_message_number; return; /* Expands the given message chain to insure it has enough room to list all messages now available */ grow_message_chain: procedure (p_message_chain_ptr); dcl p_message_chain_ptr pointer parameter; dcl (old_message_chain_ptr, new_message_chain_ptr) pointer; dcl idx fixed binary; old_message_chain_ptr = p_message_chain_ptr; allocate message_chain in (rdm_area) set (new_message_chain_ptr); new_message_chain_ptr -> message_chain.n_messages = old_message_chain_ptr -> message_chain.n_messages; do idx = 1 to old_message_chain_ptr -> message_chain.n_messages; new_message_chain_ptr -> message_chain.messages (idx) = old_message_chain_ptr -> message_chain.messages (idx); end; p_message_chain_ptr = new_message_chain_ptr; return; end grow_message_chain; /* Aborts the read_new_messages operation after printing an appropriate message: Errors during this operation can not abort the request line; otherwise, it would never be possible to exit read_mail as the quit request invokes this entrpyoint */ abort_read_new_messages: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); if rdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; go to RETURN_FROM_READ_NEW_MESSAGES_AFTER_ERROR; end abort_read_new_messages; RETURN_FROM_READ_NEW_MESSAGES_AFTER_ERROR: return; %page; /* Read the specified message from the mailbox if it hasn't already been read */ read_message: entry (P_rdm_invocation_ptr, P_message_number, P_message_ptr, P_code); rdm_invocation_ptr = P_rdm_invocation_ptr; mailbox_ptr = rdm_invocation.mailbox_ptr; message_number = P_message_number; if (message_number < 1) | (message_number > message_list.n_messages) then do; P_code = error_table_$bad_index; /* not a read_mail message number */ return; end; if message_list.messages (message_number).message_idx = 0 then do; P_code = emf_et_$expunged_message; return; end; message_ptr = mailbox.messages (message_list.messages (message_number).message_idx).message_ptr; if message_ptr = null () then do; /* hasn't been read yet ... */ call mail_system_$read_message (mailbox_ptr, message_list.messages (message_number).message_idx, code); if code = 0 then message_ptr = mailbox.messages (message_list.messages (message_number).message_idx).message_ptr; end; else code = 0; /* have the message already */ P_message_ptr = message_ptr; P_code = code; return; %page; /* Mark the specified message as having been processed: Once a message is processed by a request which causes the user to "see" it in some way (eg: list, print), it is marked as processed to allow the user to delete it without being queried for permission */ mark_processed: entry (P_rdm_invocation_ptr, P_message_number); rdm_invocation_ptr = P_rdm_invocation_ptr; message_number = P_message_number; if (message_number >= 1) & (message_number <= message_list.n_messages) then message_list.messages (message_number).processed = "1"b; return; /* Mark the specified message as processed and send an acknowledgement message if appropriate */ mark_processed_and_acknowledge: entry (P_rdm_invocation_ptr, P_message_number); rdm_invocation_ptr = P_rdm_invocation_ptr; mailbox_ptr = rdm_invocation.mailbox_ptr; message_number = P_message_number; if (message_number < 1) | (message_number > message_list.n_messages) then return; message_list.messages (message_number).processed = "1"b; if ^rdm_invocation.acknowledge then return; /* user doesn't want to acknowledge */ if message_list.messages (message_number).message_idx ^= 0 then message_ptr = mailbox.messages (message_list.messages (message_number).message_idx).message_ptr; else message_ptr = null (); if message_ptr ^= null () then /* don't bother unless it was already read ... */ if message.must_be_acknowledged then /* ... but don't bother the user if it fails */ call mail_system_$acknowledge_message (message_ptr, (0)); return; %page; /* Delete all marked messages: Actually, the messages are only logically deleted and are not physically deleted from the mailbox until the next call to the expunge_messages entrypoint below. If the delete_force parameter is not set, the user will be queried for permission to deleteany unprocessed messages; if the user denies permission or the user lacks access to delete any of the messages, none of the messages are deleted */ delete_messages: entry (P_rdm_invocation_ptr, P_delete_force); rdm_invocation_ptr = P_rdm_invocation_ptr; if ^P_delete_force then do; /* Check that it's OK to delete all the messages */ do message_idx = 1 to marked_chain.n_messages; message_number = marked_chain.messages (message_idx); call read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, code, "Reading message #^d from ^a. No messages deleted.", message_number, rdm_invocation.mailbox_name); if ^message.can_be_deleted then call ssu_$abort_line (rdm_invocation.sci_ptr, mlsys_et_$cant_be_deleted, "Message #^d. No messages deleted.", message_number); if ^message_list.messages (message_number).processed then do; call command_query_$yes_no (ok_to_delete, 0, ssu_$get_subsystem_and_request_name (rdm_invocation.sci_ptr), "", "Message #^d has not been processed. OK to delete?", message_number); if ^ok_to_delete then call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "No messages deleted."); end; end; end; /* Perform the deletions: all errors at this point are non-fatal */ rdm_invocation.current_message = 0; /* no current message while deleting */ last_deleted_message = 0; /* we may not actually succeed in deleting anything */ do message_idx = 1 to marked_chain.n_messages; message_number = marked_chain.messages (message_idx); call read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call abort_deletion_of_message (rdm_invocation.sci_ptr, code, "Reading message #^d from ^a. It will not be deleted.", message_number, rdm_invocation.mailbox_name); if ^message.marked_for_deletion then do; message_list.messages (message_number).processed = "1"b; call mail_system_$mark_message_for_deletion (message_ptr, code); if code ^= 0 then call abort_deletion_of_message (rdm_invocation.sci_ptr, code, "Message #^d will not be deleted.", message_number); call delete_message_from_chain (rdm_invocation.message_chains.undeleted, message_number); call add_message_to_chain (rdm_invocation.message_chains.deleted, message_number); last_deleted_message = message_number; /* keep track of last success */ end; DELETE_NEXT_MESSAGE: end; /* Set the current message to the first non-deleted message after the last deleted message */ if undeleted_chain.n_messages <= 0 then /* just deleted the last message */ if ^rdm_invocation.brief then call ioa_ ("All messages have been deleted."); if last_deleted_message > 0 then do; do message_idx = 1 to undeleted_chain.n_messages while (rdm_invocation.current_message = 0); if undeleted_chain.messages (message_idx) > last_deleted_message then rdm_invocation.current_message = undeleted_chain.messages (message_idx); end; end; return; %page; /* sets the value of the new current message; if P_old_current_msg is a not a deleted message, its value is assigned to P_new_current_msg; otherwise the next non-deleted message number is assigned. There is no current message (0 is assigned) if P_old_current_msg is a deleted message and no more non-deleted messages follow. */ set_new_current_msg: entry (P_rdm_invocation_ptr, P_old_current_msg, P_new_current_msg); rdm_invocation_ptr = P_rdm_invocation_ptr; /* check undeleted chain for the new current message; if old current message is deleted, pass back the next undeleted message number */ do idx = 1 to undeleted_chain.n_messages; if undeleted_chain.messages (idx) >= P_old_current_msg then do; P_new_current_msg = undeleted_chain.messages (idx); return; end; end; /* no undeleted messages after old current message; no longer a current message */ P_new_current_msg = 0; return; /* Prints an explanation as to why a message could not be deleted and continues with the deletion of the remaining marked messages */ abort_deletion_of_message: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); if rdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; go to DELETE_NEXT_MESSAGE; end abort_deletion_of_message; %page; /* Remove the marked messages from the list of messages to be deleted by the next call to the expunge_messages entrypoint */ retrieve_messages: entry (P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; do message_idx = 1 to marked_chain.n_messages; message_number = marked_chain.messages (message_idx); call read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call abort_retrieval_of_message (rdm_invocation.sci_ptr, code, "Reading message #^d from ^a. It will not be retrieved.", message_number, rdm_invocation.mailbox_name); if message.marked_for_deletion then do; call mail_system_$unmark_message_for_deletion (message_ptr, code); if code ^= 0 then call abort_retrieval_of_message (rdm_invocation.sci_ptr, code, "Message #^d will not be retrieved.", message_number); call delete_message_from_chain (rdm_invocation.message_chains.deleted, message_number); call add_message_to_chain (rdm_invocation.message_chains.undeleted, message_number); rdm_invocation.current_message = message_number; end; /* last message retrieved will be current */ RETRIEVE_NEXT_MESSAGE: end; return; /* Prints an explanation as to why a message could not be retrieved and continues with the retrieval of the remaining marked messages */ abort_retrieval_of_message: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); if rdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; go to RETRIEVE_NEXT_MESSAGE; end abort_retrieval_of_message; %page; /* Expunge the messages marked for deletion from the mailbox and update all message chains as appropriate */ expunge_messages: entry (P_rdm_invocation_ptr, P_error_during_expunge); rdm_invocation_ptr = P_rdm_invocation_ptr; mailbox_ptr = rdm_invocation.mailbox_ptr; P_error_during_expunge = "0"b; /* assume everything will go OK */ if mailbox.n_deleted_messages = 0 then return; /* nothing waiting to be expunged */ /* Construct an array parallel to the mailbox structure which lists the messages that are going to be deleted along with their corresponding read_mail message numbers */ mdl_n_messages = mailbox.n_messages; allocate mdl in (rdm_area) set (mdl_ptr); do message_idx = 1 to mdl.n_messages; message_number = 0; do idx = 1 to message_list.n_messages while (message_number = 0); if message_list.messages (idx).message_idx = message_idx then message_number = idx; end; if message_number = 0 then call abort_expunge_messages (rdm_invocation.sci_ptr, error_table_$bad_index, "Unable to determine the read_mail message number for message #^d in ^a.", message_idx, rdm_invocation.mailbox_name); mdl.messages (message_idx).message_number = message_number; message_ptr = mailbox.messages (message_idx).message_ptr; if message_ptr ^= null () then /* can't be marked without having been read ... */ mdl.messages (message_idx).expunged = message.marked_for_deletion; else mdl.messages (message_idx).expunged = "0"b; end; /* Now actually delete the messages and update the above list to reflect those messages which were not deleted */ on condition (sub_error_) begin; /* in case something goes wrong while deleting */ dcl 1 ci aligned like condition_info; ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= "mail_system_" then do; call continue_to_signal_ ((0)); /* not being reported by the mail system */ go to CONTINUE_FROM_HANDLER; end; delete_error_info_ptr = sub_error_info.info_ptr; call ssu_$print_message (rdm_invocation.sci_ptr, delete_error_info.code, "Unable to delete message #^d.^[ ^a^] Deletion of other messages continues.", delete_error_info.message_number, (length (delete_error_info.additional_info) > 0), delete_error_info.additional_info); mdl.messages (delete_error_info.message_number).expunged = "0"b; go to CALL_EXPUNGE_MESSAGES; CONTINUE_FROM_HANDLER: end; CALL_EXPUNGE_MESSAGES: call mail_system_$expunge_messages (mailbox_ptr, code); if (code ^= 0) & (code ^= mlsys_et_$all_messages_deleted) & (code ^= mlsys_et_$some_messages_not_deleted) then call abort_expunge_messages (rdm_invocation.sci_ptr, code, "Deleting messages from ^a.", rdm_invocation.mailbox_name); revert condition (sub_error_); rdm_invocation.mailbox_ptr = mailbox_ptr; /* said structure should have been changed by the above */ P_error_during_expunge = (code = mlsys_et_$some_messages_not_deleted); /* Finally update the message_list structure to reflect the new mailbox message numbers and remove all expunged messages from all message chains */ n_previously_expunged = 0; /* # of messages expunged before this message */ do message_idx = 1 to mdl.n_messages; message_number = mdl.messages (message_idx).message_number; if mdl.messages (message_idx).expunged then do; message_list.messages (message_number).message_idx = 0; call delete_message_from_chain (rdm_invocation.message_chains.all, message_number); call delete_message_from_chain (rdm_invocation.message_chains.undeleted, message_number); call delete_message_from_chain (rdm_invocation.message_chains.deleted, message_number); call delete_message_from_chain (rdm_invocation.message_chains.marked, message_number); call delete_message_from_chain (rdm_invocation.message_chains.marked_as_original, message_number); n_previously_expunged = n_previously_expunged + 1; end; else message_list.messages (message_number).message_idx = message_list.messages (message_number).message_idx - n_previously_expunged; end; return; /* Aborts the expunge_messages operation after printing an appropriate message */ abort_expunge_messages: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); if rdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; go to RETURN_FROM_EXPUNGE_MESSAGES_AFTER_ERROR; end abort_expunge_messages; RETURN_FROM_EXPUNGE_MESSAGES_AFTER_ERROR: P_error_during_expunge = "1"b; /* let the caller know something's very wrong */ return; %page; /* Adds the specified message to the given message chain */ add_message_to_chain: procedure (p_message_chain_ptr, p_message_number); dcl p_message_chain_ptr pointer parameter; dcl p_message_number fixed binary parameter; dcl (message_idx, idx) fixed binary; message_chain_ptr = p_message_chain_ptr; do message_idx = 1 to message_chain.n_messages; if message_chain.messages (message_idx) = p_message_number then return; if message_chain.messages (message_idx) > p_message_number then do; /*** Insert it here ... */ do idx = message_chain.n_messages to message_idx by -1; message_chain.messages (idx + 1) = message_chain.messages (idx); end; message_chain.messages (message_idx) = p_message_number; message_chain.n_messages = message_chain.n_messages + 1; return; end; end; /*** Control arrives here iff the new message should be last on the chain */ message_chain.n_messages = message_chain.n_messages + 1; message_chain.messages (message_chain.n_messages) = p_message_number; return; end add_message_to_chain; /* Removes the specified message from the given message chain */ delete_message_from_chain: procedure (p_message_chain_ptr, p_message_number); dcl p_message_chain_ptr pointer parameter; dcl p_message_number fixed binary parameter; dcl (idx, jdx) fixed binary; message_chain_ptr = p_message_chain_ptr; do idx = message_chain.n_messages to 1 by -1; /* go backwards to avoid changing loop terminator value */ if message_chain.messages (idx) = p_message_number then do; do jdx = (idx + 1) to message_chain.n_messages; message_chain.messages (jdx - 1) = message_chain.messages (jdx); end; message_chain.n_messages = message_chain.n_messages - 1; end; end; return; end delete_message_from_chain; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include mlsys_mailbox; %page; %include mlsys_message; %page; %include mlsys_delete_error_info; %page; %include condition_info; %include sub_error_info; %include condition_info_header; end rdm_mailbox_interface_;  rdm_mbx_requests_.pl1 10/02/89 0908.5rew 10/02/89 0815.0 180612 /****^ *********************************************************** * * * 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-03-21,Blair), approve(88-03-21,MCR7842), audit(88-06-29,Lippard), install(88-07-26,MR12.2-1069): Look for the savebox using the mlsys search_paths before querying the user for whether or not he wishes to create a new mbx on a save request. 2) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - added additional message_type parameter to call to rdm_message_mark_mgr_$mark_current_message to catch use of "-odl" with the current message. 3) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - the new entry set_new_current_msg in rdm_mailbox_interface_ is now called when the current message is changed to guarantee that the new current message is never a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* The read_mail log, save, and copy requests */ /* Created: October 1983 by G. Palter from sdm_mbx_requests_ */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_mbx_requests_: procedure (P_sci_ptr, P_rdm_invocation_ptr); return; /* not an entrypoint */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; /* Remaining declarations */ dcl message_specifier_idxs (n_message_specifiers_allocated) fixed binary based (message_specifier_idxs_ptr); dcl message_specifier_idxs_ptr pointer; dcl (n_message_specifiers_allocated, n_message_specifiers) fixed binary; dcl message_type fixed binary; /* all/only deleted/only non-deleted */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl error_table_$noentry fixed bin (35) ext static; dcl mbx_pathname character (mbx_pathname_lth) unaligned based (mbx_pathname_ptr); dcl mbx_pathname_ptr pointer; dcl mbx_pathname_lth fixed binary (21); dcl mbx_dirname character (168); dcl mbx_ename character (32); dcl saved_rdm_sci_ptr pointer; dcl is_original_request bit (1) aligned; /* ON => a request executed from within send_mail */ dcl (delete_after_processing, reverse_processing, have_pathname) bit (1) aligned; dcl try_to_create bit (1); dcl code fixed binary (35); /* format: off */ dcl (error_table_$badopt, error_table_$nostars, mlsys_et_$logbox_created, mlsys_et_$no_savebox, mlsys_et_$savebox_created, ssu_et_$unimplemented_request) fixed binary (35) external; /* format: on */ dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl command_query_$yes_no entry () options (variable); dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (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)); dcl mail_system_$copy_message entry (pointer, character (*), character (*), fixed binary (35)); dcl mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35)); dcl mail_system_$log_message entry (pointer, bit (1) aligned, fixed binary (35)); dcl mail_system_$save_message entry (pointer, character (*), character (*), bit (1) aligned, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl rdm_mailbox_interface_$delete_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$mark_processed_and_acknowledge entry (pointer, fixed binary); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_mailbox_interface_$set_new_current_msg entry (ptr, fixed binary, fixed binary); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$mark_current_message entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$remark_original_messages entry (pointer); dcl rdm_message_mark_mgr_$validate_message_specifier entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_request_name entry (pointer) returns (character (32)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$print_message entry () options (variable); dcl cleanup condition; dcl (index, length, null, reverse, search, size) builtin; %page; /* The "log" request: places a copy of the specified messages into the user's logbox which is created if necessary */ log_request: entry (P_sci_ptr, P_rdm_invocation_ptr); call setup_request ("1"b); /* may be a send_mail original request */ saved_rdm_sci_ptr = rdm_invocation.sci_ptr; /* for cleanup handler */ on condition (cleanup) begin; rdm_invocation.sci_ptr = saved_rdm_sci_ptr; end; rdm_invocation.sci_ptr = P_sci_ptr; /* be sure to not abort the reply request by accident */ call process_arguments ("0"b); /* don't allow any pathnames */ call mark_appropriate_messages (); /* determine which messages to process */ call process_messages (log_the_message); /* log them */ rdm_invocation.sci_ptr = saved_rdm_sci_ptr; return; /* Invoked by process_messages to actually log the given message */ log_the_message: procedure (p_message_number, p_message_ptr); dcl p_message_number fixed binary parameter; dcl p_message_ptr pointer parameter; call mail_system_$log_message (p_message_ptr, "1"b /* create if not found */, code); if code = mlsys_et_$logbox_created then do; /* announce that we just created the user's logbox */ call mail_system_$get_address_pathname (mlsys_data_$user_logbox_address, mbx_dirname, mbx_ename, ((32)" "), (0)); call ssu_$print_message (P_sci_ptr, 0, "Created ^a.", pathname_ (mbx_dirname, mbx_ename)); code = 0; /* ... make the code indicate success */ end; if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Adding message #^d to your logbox.", p_message_number); return; end log_the_message; %page; /* The "save" request: places a copy of the specified messages into the specified savebox; the user is queried for permission to create the savebox if it does not exist */ save_request: entry (P_sci_ptr, P_rdm_invocation_ptr); call setup_request ("1"b); /* may be a send_mail original request */ saved_rdm_sci_ptr = rdm_invocation.sci_ptr; /* for cleanup handler */ on condition (cleanup) begin; rdm_invocation.sci_ptr = saved_rdm_sci_ptr; end; rdm_invocation.sci_ptr = P_sci_ptr; /* be sure to not abort the reply request by accident */ call process_arguments ("1"b); /* must have a pathname: aborts if none given */ if index (reverse (mbx_pathname), reverse (".sv")) = 1 then mbx_pathname_lth = mbx_pathname_lth - length (".sv"); /* remove ".sv" to avoid generating "x.sv.sv.mbx" */ if search (mbx_pathname, "<>") > 0 then do; call expand_pathname_$add_suffix (mbx_pathname, "sv.mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_pathname); end; else do; call suffixed_name_$make (mbx_pathname, "sv.mbx", mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_pathname); call search_paths_$find_dir ("mlsys", null (), mbx_ename, "", mbx_dirname, code); if code ^= 0 then if code = error_table_$noentry then do; call expand_pathname_$add_suffix (mbx_pathname, "sv.mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_pathname); end; else call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_ename); end; call check_star_name_$entry (mbx_ename, code); if code ^= 0 then /* reject invalid names and star names */ if (code = 1) | (code = 2) then call ssu_$abort_line (P_sci_ptr, error_table_$nostars, "^a", pathname_ (mbx_dirname, mbx_ename)); else call ssu_$abort_line (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); call mark_appropriate_messages (); /* determine which messages to process */ call process_messages (save_the_message); /* save them */ rdm_invocation.sci_ptr = saved_rdm_sci_ptr; return; /* Invoked by process_messages to actually save the given message */ save_the_message: procedure (p_message_number, p_message_ptr); dcl p_message_number fixed binary parameter; dcl p_message_ptr pointer parameter; call mail_system_$save_message (p_message_ptr, mbx_dirname, mbx_ename, "0"b /* do not create if missing */, code); if code = mlsys_et_$no_savebox then do; /* ask for permission to create the savebox */ call command_query_$yes_no (try_to_create, 0, ssu_$get_subsystem_and_request_name (P_sci_ptr), "", "Do you wish to create the savebox ^a?", pathname_ (mbx_dirname, mbx_ename)); if try_to_create then /* ... permission given: try again */ call mail_system_$save_message (p_message_ptr, mbx_dirname, mbx_ename, "1"b /* create if not found */, code); else call ssu_$abort_line (P_sci_ptr, 0); /* ... no permission: stop right here */ if code = mlsys_et_$savebox_created then code = 0; end; if code ^= 0 then /* couldn't save it */ call ssu_$abort_line (P_sci_ptr, code, "Adding message #^d to the savebox ^a.", p_message_number, pathname_ (mbx_dirname, mbx_ename)); return; end save_the_message; %page; /* The "copy" request: places a copy of the specified messages into the specified mailbox which must already exist */ copy_request: entry (P_sci_ptr, P_rdm_invocation_ptr); call setup_request ("0"b); /* may not be a send_mail original request */ call process_arguments ("1"b); /* must have a pathname: aborts if none given */ if search (mbx_pathname, "<>") > 0 then do; call expand_pathname_$add_suffix (mbx_pathname, "mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_pathname); end; else do; call suffixed_name_$make (mbx_pathname, "mbx", mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_pathname); call search_paths_$find_dir ("mlsys", null (), mbx_ename, "", mbx_dirname, code); if code ^= 0 then if code = error_table_$noentry then do; call expand_pathname_$add_suffix (mbx_pathname, "mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_pathname); end; else call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_ename); end; call check_star_name_$entry (mbx_ename, code); if code ^= 0 then /* reject invalid names and star names */ if (code = 1) | (code = 2) then call ssu_$abort_line (P_sci_ptr, error_table_$nostars, "^a", pathname_ (mbx_dirname, mbx_ename)); else call ssu_$abort_line (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); call mark_appropriate_messages (); /* determine which messages to process */ call process_messages (copy_the_message); /* copy them */ return; /* Invoked by process_messages to actually copy the given message */ copy_the_message: procedure (p_message_number, p_message_ptr); dcl p_message_number fixed binary parameter; dcl p_message_ptr pointer parameter; call mail_system_$copy_message (p_message_ptr, mbx_dirname, mbx_ename, code); if code ^= 0 then /* couldn't copy it */ call ssu_$abort_line (P_sci_ptr, code, "Adding message #^d to the mailbox ^a.", p_message_number, pathname_ (mbx_dirname, mbx_ename)); return; end copy_the_message; %page; /* Prepares for the execution of one of the above requests */ setup_request: procedure (p_allow_original_request) /* options (quick) */; dcl p_allow_original_request bit (1) aligned; rdm_invocation_ptr = P_rdm_invocation_ptr; if rdm_invocation.type = SDM_INVOCATION then /* a send_mail original request ... */ if p_allow_original_request then do; /* ... and that's OK */ is_original_request = "1"b; sdm_invocation_ptr = P_rdm_invocation_ptr; rdm_invocation_ptr = sdm_invocation.rdm_invocation_ptr; if rdm_invocation_ptr = null () then call ssu_$abort_line (P_sci_ptr, 0, "This request is valid only during a ""reply"" request."); end; else call ssu_$abort_line (P_sci_ptr, ssu_et_$unimplemented_request); else is_original_request = "0"b; /* an ordinary read_mail request */ call ssu_$arg_count (P_sci_ptr, n_arguments); n_message_specifiers_allocated = n_arguments; /* can't have more message specifiers than arguments */ call cu_$grow_stack_frame (size (message_specifier_idxs), message_specifier_idxs_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, 0, "Too many message specifiers on the request line."); n_message_specifiers = 0; /* haven't actually spotted any yet */ call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); return; end setup_request; %page; /* Processes the arguments for one of the above requests */ process_arguments: procedure (p_pathname_required); dcl p_pathname_required bit (1) aligned parameter; have_pathname = "0"b; /* haven't seen a pathname yet */ reverse_processing = "0"b; /* default is to process in the order marked */ delete_after_processing = "0"b; /* default is to not delete after processing */ message_type = NON_DELETED_MESSAGES; do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a controla rgument */ if ^is_original_request & ((argument = "-delete") | (argument = "-dl")) then delete_after_processing = "1"b; else if ^is_original_request & ((argument = "-no_delete") | (argument = "-ndl")) then delete_after_processing = "0"b; else if (argument = "-include_deleted") | (argument = "-idl") then message_type = ALL_MESSAGES; else if (argument = "-only_deleted") | (argument = "-odl") then message_type = ONLY_DELETED_MESSAGES; else if (argument = "-only_non_deleted") | (argument = "-ondl") then message_type = NON_DELETED_MESSAGES; else if (argument = "-reverse") | (argument = "-rv") then reverse_processing = "1"b; else if (argument = "-no_reverse") | (argument = "-nrv") then reverse_processing = "0"b; /*** the following control arguments are obsolete: remove them in MR11 */ else if (argument = "-all") | (argument = "-a") then message_type = ALL_MESSAGES; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else do; /* a message specifier or pathname */ call rdm_message_mark_mgr_$validate_message_specifier (rdm_invocation_ptr, argument_ptr, argument_lth, ALL_MESSAGES, ""b, code); if code = 0 then do; /* ... it looks like a message specifier */ n_message_specifiers = n_message_specifiers + 1; message_specifier_idxs (n_message_specifiers) = argument_idx; end; else if p_pathname_required then /* ... it must be the pathname */ if have_pathname then /* ... but we already have one */ call ssu_$abort_line (P_sci_ptr, 0, "Only one pathname may be given. ""^a"" and ""^a""", mbx_pathname, argument); else do; /* ... first pathname */ have_pathname = "1"b; mbx_pathname_ptr = argument_ptr; mbx_pathname_lth = argument_lth; end; else /*** if ^p_pathname_required then */ call ssu_$abort_line (P_sci_ptr, code, """^a""", argument); end; end; if p_pathname_required & ^have_pathname then /* pathname missing: usage message is better here */ call ssu_$abort_line (P_sci_ptr, 0, "Usage: ^a {message_specifiers} path {-control_args}", ssu_$get_request_name (P_sci_ptr)); return; end process_arguments; %page; /* Marks the appropriate messages for processing */ mark_appropriate_messages: procedure (); dcl idx fixed binary; if n_message_specifiers = 0 then /* defaults to ... */ if is_original_request then /* ... messages being answered if from send_mail */ call rdm_message_mark_mgr_$remark_original_messages (rdm_invocation_ptr); else /* ... current message if from read_mail */ call rdm_message_mark_mgr_$mark_current_message (rdm_invocation_ptr, message_type); /* phx19099 RL - use of "-odl" with the current message will be caught during marking */ else do; /* use the messages requested by the user */ do idx = 1 to n_message_specifiers; call ssu_$arg_ptr (P_sci_ptr, message_specifier_idxs (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, message_type, ""b, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code); end; end; return; end mark_appropriate_messages; %page; /* Processes the marked messages */ process_messages: procedure (p_processor); dcl p_processor entry (fixed binary, pointer) variable parameter; dcl (first_message_idx, last_message_idx, message_idx_increment, message_idx, message_number) fixed binary; dcl message_ptr pointer; if reverse_processing then do; /* process them in the opposite order */ first_message_idx = marked_chain.n_messages; last_message_idx = 1; message_idx_increment = -1; end; else do; /* process them in the order marked */ first_message_idx = 1; last_message_idx = marked_chain.n_messages; message_idx_increment = 1; end; do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); /* phx18564 RL - set current message to message_number and guarantee that it's not deleted */ call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, message_number, rdm_invocation.current_message); /* it's current while we're working on it */ call p_processor (message_number, message_ptr); /* do the request-specific processing */ call rdm_mailbox_interface_$mark_processed_and_acknowledge (rdm_invocation_ptr, message_number); end; if delete_after_processing then /* user wants them deleted after processing */ call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, "0"b); return; end process_messages; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include mlsys_data; %page; %include sdm_invocation; end rdm_mbx_requests_;  rdm_message_mark_mgr_.pl1 10/02/89 0908.5rew 10/02/89 0815.0 393012 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * 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-09,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Changed to process the keywords "seen", "unseen", and "new". 2) change(86-03-04,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Added keywords (first last previous next)_(seen unseen). 3) change(86-03-05,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Added entry points first_request, last_request, all_request, current_request, seen_request, new_request, etc. Also brought over other requests from obsolete rdm_active_requests_. 4) change(86-03-07,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Replaced emf_et_$empty_range with emf_et_$no_messages_selected. 5) change(86-04-01,Herbst), approve(86-04-01,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Moved bulk of message spec requests to rdm_msg_requests. 6) change(86-04-04,Herbst), approve(86-04-04,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Fixed unitialized code bug processing "new" keyword when no new messages and the last message is an interactive one. 7) change(86-04-28,Herbst), approve(86-04-28,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Deleted unused declarations. 8) change(86-08-06,Margolin), approve(86-08-06,MCR7508), audit(86-08-27,Blair), install(86-08-29,MR12.0-1142): Pass the error code up to the calling program when no messages are selected. Fixes error_list #500 (TRs 20435 20438). Also, now it doesn't set P_code if entered via the do_request entrypoint. 9) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - added parameter P_msg_type to "mark_current_message" entry so that usage of "-odl" for the current message can be caught - the current message should never be a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* read_mail Message Mark Management -- responsible for manipulating the marked and marked_as_original message chains and for processing message specifiers (ie: parsing a specifier and then marking those messages which it selects) */ /* Created: 31 December 1979 by W. Olin Sibert out of parse_msg_spec_, construct_msg_spec_, and rdm_msg_spec_ */ /* Modified: 1 June 1980 by G. Palter to add entries to manipulate the "reply" chain */ /* Modified: 17 December 1982 by G. Palter to fix the following errors on the mail_system error list: #0260, #0382, #0383: Use of binary operators (:+-&|) without a first operand are not diagnosed as invalid; #0300: The logical operators (&|) do not work */ /* Modified: September 1983 by G. Palter to rename to rdm_message_mark_mgr_, rename the check_msg_spec entrypoint to validate_message_specifier, rename the clear entrypoint to clear_marked_messages, make validate_message_specifier only check syntax, and convert to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_message_mark_mgr_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl (P_rdm_invocation_ptr, P_sci_ptr) pointer parameter; dcl P_msg_spec_ptr pointer parameter; /* -> message_specifier to parse and (maybe) process */ dcl P_msg_spec_lth fixed binary (21) parameter; /* ... length of said specifier */ dcl P_msg_type fixed binary parameter; /* types of messages to select: all, delete, non-deleted */ dcl P_flags bit (*) parameter; dcl P_keyword_number fixed binary parameter; dcl P_reverse_sw bit (1) aligned parameter; dcl P_code fixed binary (35) parameter; /* Local copies of parameters */ dcl msg_spec_str character (msg_spec_lth) unaligned based (msg_spec_str_ptr); dcl msg_spec_lth fixed binary (21); dcl msg_spec_str_ptr pointer; dcl msg_type fixed binary; dcl code fixed binary (35); /* Information for requests/active requests */ dcl request_entry_sw bit (1) aligned init ("0"b); /* The individual tokens comprising a message specifier */ dcl 1 token aligned based (tp), 2 type fixed binary, /* number, keyword, all, regexp, etc. */ 2 value fixed binary (35), /* numeric value if a number */ 2 operator fixed binary, /* type of operation for arithmetic and logical operators */ 2 str_ptr pointer, /* -> regular expression */ 2 str_lth fixed binary (21); /* ... length of the regular expression */ dcl 1 token_array (32) aligned like token automatic; /* the actual tokens */ dcl tp pointer; dcl (n_tokens, max_tokens) fixed binary; /* The internal representation of a message_specifier */ dcl 1 msg_spec aligned based (msg_spec_ptr), 2 range_info, 3 first fixed binary, /* # of first message in range */ 3 last fixed binary, /* # of last message in range */ 3 single_message bit (1) aligned, /* ON => a single message is selected */ 2 switches, 3 seen_only_sw bit (1) unaligned, /* ON => processing "seen" keyword */ 3 unseen_only_sw bit (1) unaligned, /* ON => processing "unseen" keyword */ 3 pad bit (34) unaligned, 2 string_info, 3 search_start fixed binary, /* index in typed-chain of first msg to search for regexp */ 3 search_direction fixed binary, /* direction to perform the search */ 3 all_matches bit (1) aligned, /* ON => select all messages that match */ 3 strings (msg_spec_n_strings), /* the regular expressions to match */ 4 regexp_ptr pointer, /* ... reserved */ 4 str_ptr pointer, /* ... -> the regular expression */ 4 str_len fixed binary (21), /* ... length of the regular expression */ 4 complement bit (1) aligned, /* ... ON => complement the sense of this regexp */ 4 operator fixed binary; /* ... logical operator between this and previous regexps */ dcl msg_spec_ptr pointer; dcl msg_spec_n_strings fixed binary; /* format: off */ dcl (SEARCH_FORWARD initial (1), /* ascending order */ SEARCH_BACKWARD initial (2), /* descending order */ DONT_SEARCH initial (3), /* don't */ SEARCH_SEEN initial (4), /* only seen messages */ SEARCH_UNSEEN initial (5)) /* only unseen messages */ fixed binary static options (constant); /* format: on */ /* Remaining declarations */ dcl (first_msg_number, last_msg_number, current_msg_number, prev_msg_number, next_msg_number) fixed binary; dcl (first_msg_idx, last_msg_idx, current_msg_idx, prev_msg_idx, next_msg_idx, message_idx) fixed binary; dcl (keyword_count, number_count, range_count, regexp_count) fixed binary; dcl (report_errors_sw, reset_marked_as_original, reverse) bit (1) aligned initial ("0"b); dcl NULL_STRING character (1) static options (constant) initial (" "); dcl REGEXP_DELIM character (1) static options (constant) initial ("/"); dcl REGEXP_CONCEAL character (2) static options (constant) initial ("\c"); dcl DIGITS character (10) static options (constant) initial ("0123456789"); dcl LETTERS character (54) static options (constant) initial ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ._"); /* format: off */ dcl (UC_ALPHA initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), LC_ALPHA initial ("abcdefghijklmnopqrstuvwxyz")) character (26) static options (constant); dcl (emf_et_$msg_spec_bad_expr, emf_et_$msg_spec_bad_keyword, emf_et_$msg_spec_bad_number, emf_et_$msg_spec_bad_oper, emf_et_$msg_spec_bad_range, emf_et_$msg_spec_bad_regexp, emf_et_$msg_spec_invalid, emf_et_$msg_spec_missing_delim, emf_et_$msg_spec_mixed, emf_et_$msg_spec_null, emf_et_$msg_spec_too_complex, emf_et_$no_current_message, emf_et_$no_matching_messages, emf_et_$no_messages_selected, emf_et_$no_messages, emf_et_$no_next_message, emf_et_$no_previous_message, emf_et_$no_such_message, error_table_$nomatch) fixed binary (35) external; /* format: on */ dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_search_utils_$search_message_with_regexp entry (pointer, fixed binary, pointer, fixed binary (21)) returns (bit (1) aligned); dcl search_file_$silent entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl (addr, addrel, currentsize, fixed, hbound, index, length) builtin; dcl (min, null, substr, translate, unspec, verify) builtin; %page; /* format: off */ /* Defined token types */ dcl (FIRST_TYPE initial (1), /* first token (a placeholder) */ NUMBER_TYPE initial (2), /* a number */ KEYWORD_TYPE initial (3), /* a keyword other than "all" */ ALL_KEYWORD_TYPE initial (4), /* the keyword "all" */ REGEXP_TYPE initial (5), /* a regular expression */ RANGE_OPERATOR_TYPE initial (6), /* the range delimiter (:) */ NUMBER_OPERATOR_TYPE initial (7), /* an aritmetic operator (+ -) */ REGEXP_OPERATOR_TYPE initial (8), /* a logical connector (& |) */ COMPLEMENT_OPERATOR_TYPE initial (9), /* logical complement (^) */ LAST_TYPE initial (10)) /* last token (a placeholder) */ fixed binary static options (constant); /* Defined operator types */ dcl (NO_OPERATOR initial (-1), /* no operator */ COLON_OPERATOR initial (1), /* range delimiter */ PLUS_OPERATOR initial (2), /* addition (numeric) */ MINUS_OPERATOR initial (3), /* subtraction (numeric) */ AND_OPERATOR initial (4), /* logical and */ OR_OPERATOR initial (5), /* logical or */ COMPLEMENT_OPERATOR initial (6)) /* logical complement */ fixed binary static options (constant); dcl OPERATORS character (6) static options (constant) initial (":+-&|^"); dcl OPERATOR_TYPES (6) fixed binary static options (constant) initial ( 6 /* : */, 7 /* + */, 7 /* - */, 8 /* & */, 8 /* | */, 9 /* ^ */); /* Syntax table: defines the valid syntax of a message_specifier by defining which tokens can appear sequentially within the specifier */ dcl SYNTAX_TABLE (10, 10) fixed binary static options (constant) initial ( /* FIRST NUM KWD "all" REGXP ":" "+-" "|&" "^" LAST */ /* FIRST */ 99, 000, 000, 000, 000, 7, 2, 2, 000, 1, /* NUM */ 99, 99, 6, 2, 4, 000, 000, 4, 2, 000, /* KEYWORD */ 99, 2, 99, 99, 000, 000, 000, 4, 000, 000, /* "all" */ 99, 2, 99, 99, 000, 7, 3, 3, 000, 000, /* REGEXP */ 99, 4, 5, 5, 5, 4, 4, 000, 3, 000, /* ":" */ 99, 000, 000, 7, 4, 7, 7, 7, 7, 7, /* "+-" */ 99, 000, 000, 3, 4, 7, 2, 4, 4, 2, /* "&|" */ 99, 4, 5, 5, 000, 7, 4, 2, 000, 2, /* "^" */ 99, 4, 5, 5, 000, 7, 4, 2, 2, 2, /* LAST */ 99, 99, 99, 99, 99, 99, 99, 99, 99, 99); dcl (VALID_STATE initial (0), /* these tokens may be consecutive */ EMPTY_MSG_SPEC_STATE initial (1), /* empty message_specifier */ BAD_EXPR_STATE initial (2), /* syntax error in an expression */ BAD_OPER_STATE initial (3), /* invalid use of an operator */ MIXED_EXPR_STATE initial (4), /* mixed ranges and regular expressions */ BAD_REGEXP_STATE initial (5), /* invalid position for a regular expression */ INVALID_SPEC_STATE initial (6), /* invalid syntax */ BAD_RANGE_STATE initial (7), /* invalid syntax in a range */ CANT_HAPPEN_STATE initial (99)) /* can't happen, but */ fixed binary static options (constant); /* format: on */ %page; /* Mark all messages specified by the supplied message_specifier */ mark_messages: entry (P_rdm_invocation_ptr, P_msg_spec_ptr, P_msg_spec_lth, P_msg_type, P_flags, P_code); rdm_invocation_ptr = P_rdm_invocation_ptr; msg_spec_str_ptr = P_msg_spec_ptr; msg_spec_lth = P_msg_spec_lth; msg_type = P_msg_type; report_errors_sw = "1"b; call parse_string (); call make_msg_spec (); call mark_messages (); P_code = 0; return; /* Validates the syntax of a message_specifier */ validate_message_specifier: entry (P_rdm_invocation_ptr, P_msg_spec_ptr, P_msg_spec_lth, P_msg_type, P_flags, P_code); rdm_invocation_ptr = P_rdm_invocation_ptr; msg_spec_str_ptr = P_msg_spec_ptr; msg_spec_lth = P_msg_spec_lth; msg_type = P_msg_type; P_code = 0; report_errors_sw = "0"b; call parse_string (); return; %page; /* Clear the chain of marked messages */ clear_marked_messages: entry (P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; marked_chain.n_messages = 0; /* it's so simple with the new structure */ return; /* Mark the current message: used by requests which default to the current message */ mark_current_message: entry (P_rdm_invocation_ptr, P_msg_type); rdm_invocation_ptr = P_rdm_invocation_ptr; /* phx19099 RL - check that current message is not treated as a deleted message */ if P_msg_type = ONLY_DELETED_MESSAGES then if rdm_invocation.current_message = 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, emf_et_$no_current_message); else call ssu_$abort_line (rdm_invocation.sci_ptr, (0), "Message ^d is not a deleted message.", rdm_invocation.current_message); if rdm_invocation.current_message = 0 then /* no current message ... */ if undeleted_chain.n_messages > 0 then /* ... but there are still undeleted messages */ call ssu_$abort_line (rdm_invocation.sci_ptr, emf_et_$no_current_message); else call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "There are no non-deleted messages."); marked_chain.n_messages = 1; /* will be just one message in the chain */ marked_chain.messages (1) = rdm_invocation.current_message; return; /* Mark all messages: used by requests which operate on all messages by default (eg: list) */ mark_all_messages: entry (P_rdm_invocation_ptr, P_msg_type); rdm_invocation_ptr = P_rdm_invocation_ptr; msg_type = P_msg_type; if msg_type = ALL_MESSAGES then message_chain_ptr = rdm_invocation.message_chains.all; else if msg_type = NON_DELETED_MESSAGES then message_chain_ptr = rdm_invocation.message_chains.undeleted; else /*** if msg_type = ONLY_DELETED_MESSAGES then */ message_chain_ptr = rdm_invocation.message_chains.deleted; if message_chain.n_messages = 0 then /* no messages of the given type left */ call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "There are no^[^; non-deleted^; deleted^] messages.", msg_type); marked_chain.n_messages = message_chain.n_messages; do message_idx = 1 to message_chain.n_messages; /* copy the chain to the marked chain */ marked_chain.messages (message_idx) = message_chain.messages (message_idx); end; return; %page; /* Marks each message on the current marked chain as an "original" request: This entry is called by the "reply" and "forward" requests to indicate to other requests possibly invoked by send_mail or the forward sub-subsystem which messages are the "current" messages */ mark_original_messages: entry (P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; marked_as_original_chain.n_messages = marked_chain.n_messages; do message_idx = 1 to marked_chain.n_messages; marked_as_original_chain.messages (message_idx) = marked_chain.messages (message_idx); end; return; /* Clears the messages marked as original messages: This entry is called by the "reply" and "forward" requests upon completion to (1) clear the current marked chain (which might not be what the request had marked itself) and (2) recreate the marked chain as those messages explicitly marked by the earlier call to mark_original_messages above */ clear_original_messages: entry (P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; call clear_marked_messages (rdm_invocation_ptr); reset_marked_as_original = "1"b; /* throw out the old original chain */ go to REMARK_ORIGINAL_MESSAGES; /* Remark the messages marked as the original messages by "reply" or "forward": This entry is called by a send_mail request or a forward sub-request to construct the message chain which the "reply" or "forward" request, respectively, was invoked to process */ remark_original_messages: entry (P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; reset_marked_as_original = "0"b; /* not yet done with this chain */ REMARK_ORIGINAL_MESSAGES: do message_idx = 1 to marked_as_original_chain.n_messages; call add_message_to_marked_chain (marked_as_original_chain.messages (message_idx)); end; if reset_marked_as_original then marked_as_original_chain.n_messages = 0; return; %page; /* Entry point called by rdm_msg_requests_ to mark messages for certain requests */ do_request: entry (P_sci_ptr, P_rdm_invocation_ptr, P_keyword_number, P_msg_type, P_reverse_sw); request_entry_sw = "1"b; regexp_count = 0; max_tokens = hbound (token_array, 1); n_tokens = 0; call get_token (FIRST_TYPE); if P_keyword_number = ALL_KEYWORD | P_keyword_number = SEEN_KEYWORD | P_keyword_number = UNSEEN_KEYWORD | P_keyword_number = NEW_KEYWORD then call get_token (ALL_KEYWORD_TYPE); else call get_token (KEYWORD_TYPE); token.str_ptr, msg_spec_str_ptr = addrel (addr (KEYWORDS (P_keyword_number, 1)), 1); token.str_lth, msg_spec_lth = length (KEYWORDS (P_keyword_number, 1)); token.value = P_keyword_number; call get_token (LAST_TYPE); rdm_invocation_ptr = P_rdm_invocation_ptr; msg_type = P_msg_type; reverse = P_reverse_sw; call make_msg_spec (); call mark_messages (); return; %page; /* Parses the string which is a message_specifier into tokens and validates its syntax */ parse_string: procedure (); dcl ntp pointer; dcl keyword character (32) varying; dcl char1 character (1) aligned; dcl (number_value, code) fixed binary (35); dcl (idx, jdx, i1, i2) fixed binary (21); dcl (token_idx, operator_idx) fixed binary; max_tokens = hbound (token_array, 1); n_tokens = 0; /* start out with no tokens, of course */ call get_token (FIRST_TYPE); /* dummy token at the beginning */ idx = 1; /* index of character to begin current token */ do while (idx <= msg_spec_lth); char1 = substr (msg_spec_str, idx, 1); if index (OPERATORS, char1) ^= 0 then do; operator_idx = index (OPERATORS, char1); call get_token (OPERATOR_TYPES (operator_idx)); token.operator = operator_idx; idx = idx + 1; end; else if index (DIGITS, char1) ^= 0 then do; /* the beginning of a number */ jdx = verify (substr (msg_spec_str, idx), DIGITS); if jdx = 0 then /* j is the length of the putative number */ jdx = msg_spec_lth - idx + 1; else jdx = jdx - 1; if jdx > 6 then call abort_parse (emf_et_$msg_spec_bad_number); number_value = fixed (substr (msg_spec_str, idx, jdx)); call get_token (NUMBER_TYPE); token.value = number_value; idx = idx + jdx; /* move on to the next keyword */ end; else if index (LETTERS, char1) ^= 0 then do; /* test for a keyword */ jdx = verify (substr (msg_spec_str, idx), LETTERS); if jdx = 0 then /* j is the length of the possible keyword */ jdx = msg_spec_lth - idx + 1; else jdx = jdx - 1; keyword = substr (msg_spec_str, idx, min (32, jdx)); /* get a value for comparison */ keyword = translate (keyword, LC_ALPHA, UC_ALPHA); /* make it case independent */ do i1 = 1 to hbound (KEYWORDS, 1); /* loop through the possible keywords */ if keyword = KEYWORDS (i1, 1) then go to GOOD_KEYWORD; /* it's the long form already */ do i2 = 2 to hbound (KEYWORDS, 2); /* loop through the possible short forrms */ if keyword = KEYWORDS (i1, i2) then do; /* found one */ keyword = KEYWORDS (i1, 1); /* convert to the long form */ go to GOOD_KEYWORD; end; end; end; /* of keyword testing loop */ call abort_parse (emf_et_$msg_spec_bad_keyword); GOOD_KEYWORD: if keyword = "all" | keyword = "seen" | keyword = "unseen" | keyword = "new" then call get_token (ALL_KEYWORD_TYPE); else call get_token (KEYWORD_TYPE); token.value = i1; /* numeric index of keyword */ idx = idx + jdx; /* move past it to the next token */ end; else if char1 = REGEXP_DELIM then do; /* process regular expression now */ i1 = idx + 1; /* loop index for search for second delim */ REGEXP_LOOP: if i1 > msg_spec_lth then do; /* we've run out of string! */ call abort_parse (emf_et_$msg_spec_missing_delim); end; jdx = index (substr (msg_spec_str, i1), REGEXP_DELIM); /* look for next one */ if jdx = 0 then /* didn't find it */ call abort_parse (emf_et_$msg_spec_missing_delim); if jdx > 3 then /* look for a concealed delim if there's room */ if substr (msg_spec_str, i1 + jdx - 3, 2) = REGEXP_CONCEAL then do; i1 = i1 + jdx; /* bump the index past it */ go to REGEXP_LOOP; /* and look again */ end; call get_token (REGEXP_TYPE); token.str_ptr = addr (substr (msg_spec_str, idx + 1, 1)); /* the regexp, without the slash */ token.str_lth = ((i1 + jdx) - idx) - 2; /* length of regexp */ idx = idx + ((i1 + jdx) - idx); /* skip the regexp and delims */ call search_file_$silent (token.str_ptr, 1, token.str_lth, addr (NULL_STRING), 1, 0, (0), (0), code); if code = error_table_$nomatch then /* can only get this far if the string's syntax is OK */ code = 0; if code ^= 0 then call abort_parse (code); end; else call abort_parse (emf_et_$msg_spec_invalid); /* evil character found */ end; /* of token generating loop */ call get_token (LAST_TYPE); /* Validate the syntax of the tokens comprising this message_specifier */ regexp_count, number_count, range_count, keyword_count = 0; do token_idx = 1 to n_tokens - 1; tp = addr (token_array (token_idx)); ntp = addr (token_array (token_idx + 1)); idx = SYNTAX_TABLE (token.type, ntp -> token.type); /* is this a legal pair? */ if idx ^= VALID_STATE then do; /* no, it's illegal */ if idx = EMPTY_MSG_SPEC_STATE then code = emf_et_$msg_spec_null; else if idx = BAD_EXPR_STATE then code = emf_et_$msg_spec_bad_expr; else if idx = BAD_OPER_STATE then code = emf_et_$msg_spec_bad_oper; else if idx = MIXED_EXPR_STATE then code = emf_et_$msg_spec_mixed; else if idx = BAD_REGEXP_STATE then code = emf_et_$msg_spec_bad_regexp; else if idx = BAD_RANGE_STATE then code = emf_et_$msg_spec_bad_range; else code = emf_et_$msg_spec_invalid; call abort_parse (code); /* some error detected here */ end; if token.type = NUMBER_TYPE then number_count = number_count + 1; else if token.type = REGEXP_TYPE then regexp_count = regexp_count + 1; else if token.type = KEYWORD_TYPE then keyword_count = keyword_count + 1; else if token.type = RANGE_OPERATOR_TYPE then/* just check for range */ range_count = range_count + 1; end; /* of syntax checking loop through tokens */ if regexp_count ^= 0 then do; if number_count > 0 then /* no numbers allowed */ call abort_parse (emf_et_$msg_spec_mixed); else if keyword_count > 1 then /* only one keyword allowed in a regexp-type specifier */ call abort_parse (emf_et_$msg_spec_invalid); end; if range_count > 1 then /* only one range per specifier */ call abort_parse (emf_et_$msg_spec_invalid); return; end parse_string; %page; get_token: procedure (p_type); dcl p_type fixed binary parameter; if n_tokens >= max_tokens then call abort_parse (emf_et_$msg_spec_too_complex); n_tokens = n_tokens + 1; tp = addr (token_array (n_tokens)); unspec (token) = ""b; token.str_ptr = null (); token.type = p_type; return; end get_token; %page; /* Constructs the msg_spec structure which defines the semantics of a message_specifier */ make_msg_spec: procedure () /* options (quick) */; dcl (low_range_found, high_range_found) bit (1) aligned; dcl (keyword_msg_number, low_range, high_range, code) fixed binary (35); dcl (token_idx, regexp_idx, prev_operator, bad_msg_number, keyword_msg_idx) fixed binary; if msg_type = ALL_MESSAGES then message_chain_ptr = rdm_invocation.message_chains.all; else if msg_type = NON_DELETED_MESSAGES then message_chain_ptr = rdm_invocation.message_chains.undeleted; else /*** if msg_type = ONLY_DELETED_MESSAGES then */ message_chain_ptr = rdm_invocation.message_chains.deleted; call get_message_numbers_and_indices (); /* need pointers to the relevant messages */ msg_spec_n_strings = regexp_count; call cu_$grow_stack_frame (currentsize (msg_spec), msg_spec_ptr, code); if code ^= 0 then call abort_parse (emf_et_$msg_spec_too_complex); unspec (msg_spec) = ""b; msg_spec.first, msg_spec.last = -1; msg_spec.search_start = 0; msg_spec.search_direction = DONT_SEARCH; regexp_idx = 1; /* it will be used as a subscript when installing regexps */ low_range_found, high_range_found = "0"b; prev_operator = NO_OPERATOR; do token_idx = 2 to n_tokens - 1; /* loop through the real tokens */ tp = addr (token_array (token_idx)); if token.type = NUMBER_TYPE then do; /* either a start or an end */ low_range_found = "1"b; /* remember we found a number */ if ^high_range_found then /* must be part of lower bound */ call apply_number_operator (prev_operator, low_range, token.value); else call apply_number_operator (prev_operator, high_range, token.value); prev_operator = NO_OPERATOR; /* forget about operators 'till we see another one */ end; else if token.type = RANGE_OPERATOR_TYPE then do; if ^high_range_found then do; /* indicate that a range has been started */ prev_operator = NO_OPERATOR; high_range_found = "1"b; end; else call abort_parse (emf_et_$msg_spec_bad_range); end; /* of case for range operator */ else if token.type = REGEXP_OPERATOR_TYPE then msg_spec.operator (regexp_idx) = token.operator; else if token.type = NUMBER_OPERATOR_TYPE | token.type = COMPLEMENT_OPERATOR_TYPE then prev_operator = token.operator; else if token.type = KEYWORD_TYPE then do; /* process possible keywords */ if token.value = FIRST_KEYWORD then do; if first_msg_number = 0 then call no_message (emf_et_$no_messages); keyword_msg_number = first_msg_number; keyword_msg_idx = first_msg_idx; /* in case we have to start a search */ msg_spec.search_direction = SEARCH_FORWARD; end; else if token.value = LAST_KEYWORD then do; if last_msg_number = 0 then call no_message (emf_et_$no_messages); keyword_msg_number = last_msg_number; keyword_msg_idx = last_msg_idx; msg_spec.search_direction = SEARCH_BACKWARD; end; else if token.value = CURRENT_KEYWORD then do; if current_msg_number = 0 then call no_message (emf_et_$no_current_message); keyword_msg_number = current_msg_number; keyword_msg_idx = current_msg_idx; msg_spec.search_direction = DONT_SEARCH; end; else if token.value = NEXT_KEYWORD then do; if next_msg_number = 0 then call no_message (emf_et_$no_next_message); keyword_msg_number = next_msg_number; keyword_msg_idx = next_msg_idx; msg_spec.search_direction = SEARCH_FORWARD; end; else if token.value = PREVIOUS_KEYWORD then do; if prev_msg_number = 0 then call no_message (emf_et_$no_previous_message); keyword_msg_number = prev_msg_number; keyword_msg_idx = prev_msg_idx; msg_spec.search_direction = SEARCH_BACKWARD; end; else if token.value = FIRST_SEEN_KEYWORD then call search_message (first_msg_idx, SEARCH_FORWARD, SEARCH_SEEN); else if token.value = FIRST_UNSEEN_KEYWORD then call search_message (first_msg_idx, SEARCH_FORWARD, SEARCH_UNSEEN); else if token.value = LAST_SEEN_KEYWORD then call search_message (last_msg_idx, SEARCH_BACKWARD, SEARCH_SEEN); else if token.value = LAST_UNSEEN_KEYWORD then call search_message (last_msg_idx, SEARCH_BACKWARD, SEARCH_UNSEEN); else if token.value = PREVIOUS_SEEN_KEYWORD then call search_message (current_msg_idx - 1, SEARCH_BACKWARD, SEARCH_SEEN); else if token.value = PREVIOUS_UNSEEN_KEYWORD then call search_message (current_msg_idx - 1, SEARCH_BACKWARD, SEARCH_UNSEEN); else if token.value = NEXT_SEEN_KEYWORD then call search_message (current_msg_idx + 1, SEARCH_FORWARD, SEARCH_SEEN); else if token.value = NEXT_UNSEEN_KEYWORD then call search_message (current_msg_idx + 1, SEARCH_FORWARD, SEARCH_UNSEEN); else call abort_parse (emf_et_$msg_spec_bad_keyword); /* shouldn't ever happen, since */ /* we've now gotten through all the possible keywords */ if msg_spec_n_strings > 0 then /* this means the keyword is a "string" keyword */ msg_spec.search_start = keyword_msg_idx; else do; /* otherwise, it's a number */ if ^high_range_found then do; call apply_number_operator (prev_operator, low_range, keyword_msg_number); low_range_found = "1"b; /* so we won't make the mistake later */ prev_operator = NO_OPERATOR; end; else call apply_number_operator (prev_operator, high_range, keyword_msg_number); end; /* of case for a "number", as opposed to a "string" keyword */ end; /* of case for keyword (other than "all") */ else if token.type = ALL_KEYWORD_TYPE then do; if (first_msg_number = 0) | (last_msg_number = 0) then call no_message (emf_et_$no_messages); if token.value = NEW_KEYWORD then do; low_range_found = "0"b; prev_msg_idx = 0; do message_idx = message_chain.n_messages by -1 to 1 while (^low_range_found); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_chain.messages (message_idx), message_ptr, code); if code ^= 0 | message.flags.seen then do; low_range_found = "1"b; if prev_msg_idx = 0 then call no_message (emf_et_$no_messages_selected); else low_range = message_chain.messages (prev_msg_idx); end; prev_msg_idx = message_idx; end; if ^low_range_found then low_range = first_msg_number; end; else low_range = first_msg_number; high_range = last_msg_number; low_range_found, high_range_found = "1"b; if token.value = SEEN_KEYWORD then msg_spec.seen_only_sw = "1"b; else if token.value = UNSEEN_KEYWORD then msg_spec.unseen_only_sw = "1"b; else if msg_spec_n_strings > 0 then do; /* "all" is a special case for this */ msg_spec.search_start = first_msg_idx; msg_spec.search_direction = SEARCH_FORWARD; msg_spec.all_matches = "1"b; end; end; /* of case for "all" */ else if token.type = REGEXP_TYPE then do; msg_spec.str_ptr (regexp_idx) = token.str_ptr; msg_spec.str_len (regexp_idx) = token.str_lth; if prev_operator = COMPLEMENT_OPERATOR then msg_spec.complement (regexp_idx) = "1"b; regexp_idx = regexp_idx + 1; prev_operator = NO_OPERATOR; /* compliment applies to exactly one regexp */ end; end; /* of token processing loop */ if (first_msg_number = 0) | (last_msg_number = 0) then call no_message (emf_et_$no_messages); /* there's not much that can be done */ if ^low_range_found then do; if msg_spec_n_strings = 0 then do; if current_msg_number = 0 then call no_message (emf_et_$no_current_message); high_range, low_range = current_msg_number; end; else do; /* default to 'all' for strings */ low_range = first_msg_number; high_range = last_msg_number; high_range_found = "1"b; end; low_range_found = "1"b; end; if ^high_range_found then do; /* check for validity */ high_range = low_range; msg_spec.single_message = "1"b; /* indicate that a single message was asked for */ end; if (high_range <= 0) | (low_range <= 0) | (low_range > high_range) then call abort_parse (emf_et_$msg_spec_bad_range); bad_msg_number = -1; /* check ranges against absolute message boundaries */ if high_range > all_chain.messages (all_chain.n_messages) then bad_msg_number = high_range; if low_range < all_chain.messages (1) then bad_msg_number = low_range; if bad_msg_number ^= -1 then /* this code is only reached with report_errors_sw OFF */ call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "There is no message ^d.", bad_msg_number); if msg_spec.search_direction = DONT_SEARCH then do; if msg_spec_n_strings > 0 then msg_spec.all_matches = "1"b; msg_spec.search_direction = SEARCH_FORWARD; end; msg_spec.first = low_range; msg_spec.last = high_range; return; %page; /* Internal to make_msg_spec: sets the values of the current, first, last, previous, and next message numbers along with their indices in the type-specific message chain */ get_message_numbers_and_indices: procedure (); dcl idx fixed binary; if message_chain.n_messages = 0 then /* first and last are undefined */ first_msg_number, first_msg_idx, last_msg_number, last_msg_idx = 0; else do; /* they're defined ... */ first_msg_number = message_chain.messages (1); first_msg_idx = 1; last_msg_number = message_chain.messages (message_chain.n_messages); last_msg_idx = message_chain.n_messages; end; current_msg_number = rdm_invocation.current_message; if current_msg_number = 0 then /* no current message */ current_msg_idx = 0; else do; /* check if it's in this type-specific chain */ current_msg_idx = 0; do idx = 1 to message_chain.n_messages while (current_msg_idx = 0); if message_chain.messages (idx) = current_msg_number then current_msg_idx = idx; end; end; if current_msg_number = 0 then /* no current message: previous and next are undefined */ prev_msg_number, prev_msg_idx, next_msg_number, next_msg_idx = 0; else do; /* find them in the chain ... */ /*** ... previous is last message before the current message */ prev_msg_number, prev_msg_idx = 0; do idx = message_chain.n_messages to 1 by -1 while (prev_msg_idx = 0); if message_chain.messages (idx) < current_msg_number then do; prev_msg_number = message_chain.messages (idx); prev_msg_idx = idx; end; end; /*** ... next is first message after the current mesage */ next_msg_number, next_msg_idx = 0; do idx = 1 to message_chain.n_messages while (next_msg_idx = 0); if message_chain.messages (idx) > current_msg_number then do; next_msg_number = message_chain.messages (idx); next_msg_idx = idx; end; end; end; return; end get_message_numbers_and_indices; %page; /* Internal to make_msg_spec: applies a numeric operator (+ -) */ apply_number_operator: procedure (p_operator, p_operand_1, p_operand_2); dcl p_operator fixed binary parameter; dcl p_operand_1 fixed binary (35) parameter; dcl p_operand_2 fixed binary (35) parameter; if p_operator = NO_OPERATOR then p_operand_1 = p_operand_2; else if p_operator = MINUS_OPERATOR then p_operand_1 = p_operand_1 - p_operand_2; else if p_operator = PLUS_OPERATOR then p_operand_1 = p_operand_1 + p_operand_2; return; end apply_number_operator; %page; /* Internal to make_msg_spec: searches for first_seen, etc. */ search_message: proc (P_start_message_idx, P_search_direction, P_seen_unseen); dcl (P_start_message_idx, P_search_direction, P_seen_unseen, increment, message_idx) fixed bin; if P_search_direction = SEARCH_FORWARD then increment = 1; else increment = -1; do message_idx = P_start_message_idx by increment while (message_idx >= 1 & message_idx <= message_chain.n_messages); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_chain.messages (message_idx), message_ptr, code); if code ^= 0 then call abort_parse (emf_et_$no_such_message); if message.flags.seen = (P_seen_unseen = SEARCH_SEEN) then do; keyword_msg_number = message_chain.messages (message_idx); keyword_msg_idx = message_idx; msg_spec.search_direction = DONT_SEARCH; return; end; end; call no_message (emf_et_$no_such_message); end search_message; end make_msg_spec; %page; /* Marks the messages which are selected by the message_specifier: Messages are only marked once even if selected by several message_specifiers so that they will always be processed in the order specified */ mark_messages: procedure (); dcl (continue_searching, ms_matched, this_matched) bit (1) aligned; dcl (first_message_idx, next_message_idx, message_idx, message_number, match_count, idx) fixed binary; if msg_spec.search_start > 0 then do; /* a keyword preceded the strings */ search_direction = msg_spec.search_direction; first_message_idx = msg_spec.search_start; end; else do; /* otherwise, do it for "all" */ search_direction = SEARCH_FORWARD; first_message_idx = 1; end; match_count = 0; /* to keep track of matches */ do message_idx = first_message_idx repeat (next_message_idx) while ((message_idx > 0) & (message_idx <= message_chain.n_messages)); if search_direction = SEARCH_FORWARD then next_message_idx = message_idx + 1; else if search_direction = SEARCH_BACKWARD then next_message_idx = message_idx - 1; else next_message_idx = 0; message_number = message_chain.messages (message_idx); if (message_number >= msg_spec.first) & (message_number <= msg_spec.last) then do; /* the message number is within range ... */ continue_searching = "1"b; ms_matched = "1"b; do idx = 1 to msg_spec_n_strings while (continue_searching); this_matched = rdm_search_utils_$search_message_with_regexp (rdm_invocation_ptr, message_number, msg_spec.str_ptr (idx), msg_spec.str_len (idx)); if msg_spec.complement (idx) then this_matched = ^this_matched; if msg_spec.operator (idx) = OR_OPERATOR then ms_matched = ms_matched | this_matched; else if msg_spec.operator (idx) = AND_OPERATOR then do; ms_matched = ms_matched & this_matched; continue_searching = ms_matched; end; /* search more only if necessary */ else ms_matched = this_matched; /* no operator specified, presumably */ end; if msg_spec.seen_only_sw | msg_spec.unseen_only_sw then do; call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call abort_parse (code); if message.flags.seen ^= msg_spec.seen_only_sw then ms_matched = "0"b; end; if ms_matched then do; /* we won */ match_count = match_count + 1; call add_message_to_marked_chain (message_number); if ^msg_spec.all_matches & (msg_spec_n_strings > 0) then next_message_idx = 0; end; /* ...stop on first match unless "all" was used */ end; end; if match_count = 0 & ^request_entry_sw then do; /* no match */ if report_errors_sw & msg_spec.single_message then if msg_type = ONLY_DELETED_MESSAGES then/* complain about a missing message */ call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "Message ^d is not a deleted message.", msg_spec.first); else if msg_type = NON_DELETED_MESSAGES then call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "Message ^d has already been deleted.", msg_spec.first); else call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "There is no message ^d.", msg_spec.first); else if msg_spec.single_message then call abort_parse (emf_et_$no_such_message); else if msg_spec_n_strings > 0 then call abort_parse (emf_et_$no_matching_messages); else call abort_parse (emf_et_$no_messages_selected); end; return; end mark_messages; %page; /* Adds the specified message to the marked chain iff it is not already in the chain */ add_message_to_marked_chain: procedure (p_message_number); dcl p_message_number fixed binary parameter; dcl idx fixed binary; do idx = 1 to marked_chain.n_messages; if marked_chain.messages (idx) = p_message_number then return; end; marked_chain.n_messages, idx = marked_chain.n_messages + 1; marked_chain.messages (idx) = p_message_number; return; end add_message_to_marked_chain; %page; /* Routine to return from message spec processing if there are no messages of the specified type. If the caller is a keyword active request it will return the null string or 0 as appropriate. */ no_message: procedure (p_code); dcl p_code fixed bin (35) parameter; if ^request_entry_sw then P_code = p_code; /* do_request has no code parameter */ go to ERROR_RETURN_FROM_VALIDATE_MESSAGE_SPECIFIER; end no_message; %page; /* Aborts processing of the message_specifier and optionally prints an error message */ abort_parse: procedure (p_code); dcl p_code fixed bin (35) parameter; dcl message character (64) varying; dcl type_str character (32) varying; if report_errors_sw then do; if msg_type = NON_DELETED_MESSAGES then type_str = " non-deleted"; else if msg_type = ONLY_DELETED_MESSAGES then type_str = " deleted"; else type_str = ""; if p_code = emf_et_$no_previous_message then message = "There is no previous^a message. ""^a"""; else if p_code = emf_et_$no_next_message then message = "There is no next^a message. ""^a"""; else if p_code = emf_et_$no_messages then message = "There are no^a messages. ""^a"""; else if p_code = emf_et_$no_messages_selected then message = "No^a messages selected. ""^a"""; else if p_code = emf_et_$no_matching_messages then message = "No matching^a messages. ""^a"""; else message = ""; if length (message) > 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, 0, message, type_str, msg_spec_str); else call ssu_$abort_line (rdm_invocation.sci_ptr, p_code, """^a""", msg_spec_str); end; else do; if ^request_entry_sw then /* do_request has no code parameter */ P_code = p_code; /* copy it to the main procedure error code */ go to ERROR_RETURN_FROM_VALIDATE_MESSAGE_SPECIFIER; end; end abort_parse; ERROR_RETURN_FROM_VALIDATE_MESSAGE_SPECIFIER: return; %page; %include mlsys_mailbox; %page; %include mlsys_message; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_msg_spec_keywords; %page; %include rdm_message_chains; end rdm_message_mark_mgr_;  rdm_misc_requests_.pl1 10/27/83 1616.3rew 10/27/83 1442.2 61740 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* Miscellaneous read_mail requests */ /* Created: 1978 by W. Olin Sibert */ /* Modified: 30 May 1980 by G. Palter to implement suggestion #0316 -- the "." requests should indicate if abbrev processing is enabled */ /* Modified: 16 February 1982 by G. Palter for new calling sequence of ssu_$get_abbrev_info */ /* Modified: 21 September 1982 by G. Palter to stop using rdm_data_ and to make the quit request accept -no_force and -delete/-no_delete */ /* Modified: September 1983 by G. Palter as part of the conversion to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_misc_requests_: procedure (P_sci_ptr, P_rdm_invocation_ptr); return; /* not an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl request_name character (72) varying; dcl quit_force bit (1); /* command_query_$yes_no is declared wrong */ dcl (delete_messages, expunge_failed) bit (1) aligned; dcl n_new_messages fixed binary; dcl (subsystem_name, subsystem_version) character (32); dcl subsystem_level fixed binary; dcl abbrev_enabled bit (1) aligned; /* format: off */ dcl (error_table_$bad_arg, error_table_$badopt, mlsys_et_$some_messages_not_deleted) fixed binary (35) external; /* format: on */ dcl command_query_$yes_no entry () options (variable); dcl ioa_ entry () options (variable); dcl rdm_mailbox_interface_$expunge_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$read_new_messages entry (pointer, bit (1) aligned, fixed binary); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned); dcl ssu_$get_invocation_count entry (pointer, fixed binary, fixed binary); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$get_subsystem_name entry (pointer) returns (character (32)); dcl ssu_$get_subsystem_version entry (pointer) returns (character (32)); dcl ssu_$print_message entry () options (variable); dcl (index, null, substr) builtin; %page; /* The "quit" request: exists read_mail unless new messages have arrived, in which case, the user is queried */ quit_request: entry (P_sci_ptr, P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; request_name = ssu_$get_subsystem_and_request_name (P_sci_ptr); quit_force = "0"b; /* ask if new messages present */ delete_messages = "1"b; /* delete messages so marked */ call ssu_$arg_count (P_sci_ptr, n_arguments); do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-force") | (argument = "-fc") then quit_force = "1"b; else if (argument = "-no_force") | (argument = "-nfc") then quit_force = "0"b; else if (argument = "-delete") | (argument = "-dl") then delete_messages = "1"b; else if (argument = "-no_delete") | (argument = "-ndl") then delete_messages = "0"b; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, error_table_$bad_arg, "This request only accepts control arguments.") ; end; call rdm_mailbox_interface_$read_new_messages (rdm_invocation_ptr, "0"b, n_new_messages); if ^quit_force & (n_new_messages > 0) then do; /* give user a change to look */ call command_query_$yes_no (quit_force, 0, request_name, "", "^[One new message has^s^;^d new messages have^] arrived. Do you still wish to quit?", (n_new_messages = 1), n_new_messages); if ^quit_force then call ssu_$abort_line (P_sci_ptr); end; if delete_messages then do; /* actually flush deleted messages */ call rdm_mailbox_interface_$expunge_messages (rdm_invocation_ptr, expunge_failed); if expunge_failed then /* .. unable to delete everything that should have been ... */ if quit_force then /* ... but user wants out anyway: warn of possible error */ call ssu_$print_message (P_sci_ptr, mlsys_et_$some_messages_not_deleted); else call ssu_$abort_line (P_sci_ptr, mlsys_et_$some_messages_not_deleted); end; call ssu_$abort_subsystem (P_sci_ptr, 0); /* leave */ return; /* can't get here */ %page; /* format: off */ /* The "." request: prints a line of the form: read_mail V {(abbrev)} {(debug)} {(level N)}: No current message. # messages, # deleted. PATHNAME where items enclosed in {}'s are optionally printed if meaningfull */ /* format: on */ self_identify: entry (P_sci_ptr, P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; mailbox_ptr = rdm_invocation.mailbox_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (P_sci_ptr, 0, "No arguments may be given."); call rdm_mailbox_interface_$read_new_messages (rdm_invocation_ptr, "1"b, (0)); /* say what's new */ subsystem_name = ssu_$get_subsystem_name (P_sci_ptr); subsystem_version = ssu_$get_subsystem_version (P_sci_ptr); call ssu_$get_abbrev_info (P_sci_ptr, (null ()), (null ()), abbrev_enabled); call ssu_$get_invocation_count (P_sci_ptr, subsystem_level, (0)); call ioa_ ( "^a ^a^[ (abbrev)^]^[ (debug)^]^[ (level ^d)^;^s^]: ^[Message #^d of ^d^s^;^sNo current message. ^d message^[s^]^]^[, ^d deleted^;^s^]. ^[Reading ^a.^;^a^]" , subsystem_name, subsystem_version, abbrev_enabled, rdm_invocation.debug_mode, (subsystem_level ^= 1), subsystem_level, (rdm_invocation.current_message ^= 0), rdm_invocation.current_message, all_chain.n_messages, (all_chain.n_messages ^= 1), (deleted_chain.n_messages > 0), deleted_chain.n_messages, (substr (rdm_invocation.mailbox_name, 1, 1) ^= ">"), rdm_invocation.mailbox_name) ; return; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; end rdm_misc_requests_;  rdm_msg_requests_.pl1 04/24/92 1657.0r w 04/24/92 1626.7 585234 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * 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-19,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Added $switch_on_request and $switch_off_request. 2) change(86-02-27,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Changed print request to turn on message's seen switch. 3) change(86-03-25,Herbst), approve(86-03-25,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Changed switch_type from fixed bin to char (4) aligned. 4) change(86-04-01,Herbst), approve(86-04-01,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Moved request entry points here from rdm_message_mark_mgr_. 5) change(86-04-04,Herbst), approve(86-04-04,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Fixed to print a blank line for "new" request if no new messages. 6) change(86-04-28,Herbst), approve(86-04-28,MCR7367), audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): Changed error message for invalid request arguments. 7) change(89-04-03,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx20589, Mail 502 - added test in perform_list_request to prevent the current message from being changed if called as an active function. 8) change(89-04-03,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19118, Mail 459 - corrected direction of comparison in "-btt" test for valid date/time range. 9) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - added message_type parameter to call to rdm_message_mark_mgr_$mark_current_message to catch use of "-odl" with the current message. 10) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - the new entry set_new_current_msg in rdm_mailbox_interface_ is now called when the current message is changed to guarantee that the new current message is never a deleted message; reformatting. 11) change(91-12-17,Huen), approve(91-12-17,MCR8239), audit(92-02-13,Zimmerman), install(92-04-24,MR12.5-1013): Fix mail_362 - check for new messages after every request line. END HISTORY COMMENTS */ /* format: off */ /* read_mail message handling requests: list, print, print_header, delete, retrieve send_mail original message handling requests: list_original, print_original, print_original_header forward original message handling sub-requests: print_original */ /* Created: Late 1978 by W. Olin Sibert */ /* Recoded: 30 December 1979 by W. Olin Sibert to add extended selection control arguments */ /* Modified: 1 January 1980 by W. Olin Sibert to fix more bugs in setting the current message */ /* Modified: 1 June 1980 by G. Palter address the following entries on the mail system error list -- #0263: current message in read_mail should be set to the message being processed - thus, if an error occurs, the current message will remain on which the error occured; #0186: there should be a "print_original" request in send_mail which prints the message being replied to when invoked by read_mail's "reply" request */ /* Modified: 4 June 1980 by G. Palter address the following entries on the mail system error list -- #0293: read_mail's "print" request accepts the "-delete" control argument, but doesn't honor it; #0219: listing by "-redistributed_to" or "-recipient" faults because of the organization of forwarding fields */ /* Modified: 3 November 1981 by W. Olin Sibert to fix bug #0219, again */ /* Modified: 30 March 1982 by G. Palter to address the following entries on the mail system error list -- #0299: the "-brief", "-long", and "-mseg_info" control arguments of the "list" request are not implemented; and #0283: add "-line_length" and "-no_line_length" control arguments to the "list" request */ /* Modified: 24 September 1982 by G. Palter to use the same control arguments to specify case sensitivity as the new sort_seg command */ /* Modified: 8 October 1982 by G. Palter to not reference sys_info$time_correction_constant */ /* Modified: 28 October 1982 by G. Palter to make case insensitive searching work and to make the "-recipient" control argument properly recognize regular expression matching */ /* Modified: October 1983 by G. Palter as part of the conversion to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_msg_requests_: procedure (P_sci_ptr, P_rdm_invocation_ptr); return; /* not an entry */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; /* Remaining declarations */ dcl is_original_request bit (1) aligned; /* ON => invoked from send_mail or forward sub-request loop */ dcl saved_rdm_sci_ptr pointer; dcl msg_spec_array (msg_spec_array_size) fixed binary based (msg_spec_array_ptr); dcl (msg_spec_array_size, msg_spec_count) fixed binary; dcl msg_spec_array_ptr pointer; dcl 1 class_sw aligned, /* which types of selection control arguments are given */ 2 time bit (1) unaligned, 2 subject bit (1) unaligned, 2 sender bit (1) unaligned, 2 recipient bit (1) unaligned; dcl class_count (4) fixed binary; /* count of each class of selection */ dcl 1 sel aligned based (sel_ptr), 2 class fixed binary, /* class of selection -- time, text, sender, recipient */ 2 type fixed binary, /* which header field for all but time selections */ 2 time_1 fixed binary (71), /* for date/time selections ... */ 2 time_2 fixed binary (71), /* ... */ 2 string, /* for string matching */ 3 regexp_sw bit (1) aligned, /* ON => string is a regular expression */ 3 str_lth fixed binary (21), 3 str_ptr pointer, 2 address_ptr pointer; /* -> address for address matching */ dcl sel_ptr pointer; dcl 1 selection_array aligned based (selection_array_ptr), 2 array (n_selections) like sel; dcl selection_array_ptr pointer; dcl n_selections fixed binary; dcl 1 local_fmo aligned like format_message_options; dcl formatting_mode fixed binary; dcl (request, other_keyword_type) fixed binary; dcl active_request bit (1) aligned; dcl switch_type char (4) aligned; dcl (argument_idx, first_argument, n_arguments) fixed binary; dcl message_number_string char (8) varying; dcl output_buffer char (256) varying; dcl output_line_length fixed bin; dcl return_value character (return_value_max_lth) varying based (return_value_ptr); dcl return_value_ptr pointer; dcl return_value_max_lth fixed binary (21); dcl (argument, control_argument) character (argument_lth) based (argument_ptr); dcl argument1 character (argument1_lth) based (argument1_ptr); dcl argument2 character (argument2_lth) based (argument2_ptr); dcl (argument_ptr, argument1_ptr, argument2_ptr) pointer; dcl (argument_lth, argument1_lth, argument2_lth) fixed binary (21); dcl msg_type fixed binary; dcl (listing_header_sw, force_sw, delete_sw, reverse_sw, dl_rt_sw, case_independence_sw) bit (1) aligned; dcl listing_line_length fixed binary; dcl (first_message_idx, last_message_idx, message_idx_increment, message_idx, message_number) fixed binary; dcl idx fixed binary; dcl code fixed binary (35); dcl iox_$user_output pointer external; /* format: off */ dcl (error_table_$badarg, error_table_$badopt, error_table_$noarg, error_table_$nomatch, mlsys_et_$null_search_string, ssu_et_$unimplemented_request) fixed binary (35) external; dcl (LIST_REQUEST initial (1), PRINT_REQUEST initial (2), PRINT_HEADER_REQUEST initial (3), DELETE_REQUEST initial (4), RETRIEVE_REQUEST initial (5), SWITCH_OFF_REQUEST initial (6), SWITCH_ON_REQUEST initial (7), OTHER_REQUEST initial (8)) fixed binary static options (constant); dcl (LIST_INFO initial ("1"b), JUST_LIST_NUMBERS initial ("0"b)) bit (1) aligned static options (constant); dcl (SUBJECT_CLASS initial (1), TIME_CLASS initial (2), SENDER_CLASS initial (3), RECIPIENT_CLASS initial (4)) fixed binary static options (constant); dcl (ONE_DAY initial (86399999999), /* one microsecond less than 1 day */ BEGINNING_OF_TIME initial (86400000000), /* 1 January 1901 midnight GMT */ END_OF_TIME initial (3122064000000000)) /* 1 January 1999 midnight GMT */ fixed binary (71) static options (constant); dcl (LOWERCASE initial ("abcdefghijklmnopqrstuvwxyz"), UPPERCASE initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")) character (26) static options (constant); /* format: on */ dcl NULL_STRING character (1) static options (constant) initial (""); dcl SLASH character (1) static options (constant) initial ("/"); dcl convert_date_to_binary_ entry (character (*), fixed binary (71), fixed binary (35)); dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl decode_clock_value_$date_time entry (fixed binary (71), fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary (71), fixed binary, character (3), fixed binary (35)); dcl encode_clock_value_ entry (fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary (71), fixed binary, character (3), fixed binary (71), fixed binary (35)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl ioa_ entry () options (variable); dcl iox_$control entry (pointer, character (*), pointer, fixed binary (35)); dcl mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned); dcl mail_system_$free_address entry (pointer, fixed binary (35)); dcl mail_system_$set_message_switch entry (ptr, char (4) aligned, bit (1) aligned, fixed bin (35)); dcl mlsys_utils_$parse_address_control_args entry (pointer, fixed binary, pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_message entry (pointer, pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_summary entry (pointer, fixed binary, bit (1) aligned, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_summary_header entry (fixed binary, pointer, fixed binary (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl rdm_mailbox_interface_$delete_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$mark_processed entry (pointer, fixed binary); dcl rdm_mailbox_interface_$mark_processed_and_acknowledge entry (pointer, fixed binary); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_mailbox_interface_$retrieve_messages entry (pointer); dcl rdm_mailbox_interface_$set_new_current_msg entry (ptr, fixed binary, fixed binary); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$do_request entry (ptr, ptr, fixed bin, fixed bin, bit (1) aligned); dcl rdm_message_mark_mgr_$mark_all_messages entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_current_message entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$remark_original_messages entry (pointer); dcl rdm_search_utils_$prepare_address_list_field_for_search entry (pointer, fixed binary, character (*) varying, pointer, pointer, fixed binary (21)); dcl rdm_search_utils_$prepare_message_references_field_for_search entry (pointer, fixed binary, character (*) varying, pointer, pointer, fixed binary (21)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl search_file_$silent entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21)); dcl cleanup condition; dcl (addcharno, addr, convert, currentsize, divide, index, length, ltrim) builtin; dcl (maxlength, min, null, rtrim, string, substr, translate, unspec, verify) builtin; %page; /* The "list" and "list_original" requests: displays a one line summary of the selected messages */ list_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = LIST_REQUEST; go to COMMON; /* The "print" and "print_original" request: prints the specified messages. Control arguments are provided to select several different levels of detail for the information displayed from the message header */ print_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = PRINT_REQUEST; go to COMMON; /* The "print_header" and "print_original_header" requests: prints the message header of the specified messages. Control arguments are provided to control the level of detail to be displayed */ print_header_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = PRINT_HEADER_REQUEST; go to COMMON; /* The "delete" request: marks the specified messages for deletion when upon exit from read_mail */ delete_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = DELETE_REQUEST; go to COMMON; /* The "retrieve" request: unmarks the specified messages so they will not be deleted upon exit from read_mail */ retrieve_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = RETRIEVE_REQUEST; go to COMMON; /* The "switch_off" request: turns off a specified per-message switch */ switch_off_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = SWITCH_OFF_REQUEST; go to COMMON; /* The "switch_on" request: turns on a specified per-message switch */ switch_on_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = SWITCH_ON_REQUEST; go to COMMON; all_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = ALL_KEYWORD; go to COMMON; first_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = FIRST_KEYWORD; go to COMMON; last_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = LAST_KEYWORD; go to COMMON; previous_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = PREVIOUS_KEYWORD; go to COMMON; next_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = NEXT_KEYWORD; go to COMMON; current_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = CURRENT_KEYWORD; go to COMMON; seen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = SEEN_KEYWORD; go to COMMON; unseen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = UNSEEN_KEYWORD; go to COMMON; new_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = NEW_KEYWORD; go to COMMON; first_seen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = FIRST_SEEN_KEYWORD; go to COMMON; first_unseen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = FIRST_UNSEEN_KEYWORD; go to COMMON; last_seen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = LAST_SEEN_KEYWORD; go to COMMON; last_unseen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = LAST_UNSEEN_KEYWORD; go to COMMON; previous_seen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = PREVIOUS_SEEN_KEYWORD; go to COMMON; previous_unseen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = PREVIOUS_UNSEEN_KEYWORD; go to COMMON; next_seen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = NEXT_SEEN_KEYWORD; go to COMMON; next_unseen_request: entry (P_sci_ptr, P_rdm_invocation_ptr); request = OTHER_REQUEST; other_keyword_type = NEXT_UNSEEN_KEYWORD; go to COMMON; %page; COMMON: call setup_request (); /* set up common defaults */ on condition (cleanup) call cleanup_request (); rdm_invocation.sci_ptr = P_sci_ptr; /* avoids aborting the entire reply/forward accidently */ if request = RETRIEVE_REQUEST then /* retrieve request operates on deleted messages only */ msg_type = ONLY_DELETED_MESSAGES; else msg_type = NON_DELETED_MESSAGES; dl_rt_sw = (request = DELETE_REQUEST) | (request = RETRIEVE_REQUEST); /* delete and retrieve don't accept -idl/-odl/-ondl */ if (request = PRINT_REQUEST) | (request = PRINT_HEADER_REQUEST) then do; local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = 0; /* ... use the terminal's line length */ if request = PRINT_REQUEST then do; /* ... print: use default format specified to read_mail */ formatting_mode = rdm_invocation.print_options.formatting_mode; local_fmo.include_body = "1"b; end; else do; /* ... print_header: use default format by default */ formatting_mode = DEFAULT_FORMATTING_MODE; local_fmo.include_body = "0"b; end; end; else if (request = LIST_REQUEST) then do; listing_header_sw = "1"b; /* default is to print header line */ listing_line_length = 0; /* ... and to use the terminal's line length */ end; /* Mail 362: Should not check for new messages before list and print request */ /* Scan the request's arguments */ if request = SWITCH_OFF_REQUEST | request = SWITCH_ON_REQUEST then do; if n_arguments < 1 then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "No switch type specified."); call ssu_$arg_ptr (P_sci_ptr, 1, argument_ptr, argument_lth); if (argument = "seen") then switch_type = PER_MESSAGE_SEEN_SWITCH_TYPE; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, "Invalid switch type ^a", argument); first_argument = 2; end; else first_argument = 1; call process_arguments (); class_sw.time = (class_count (TIME_CLASS) ^= 0); /* determine which selection control arguments were used */ class_sw.subject = (class_count (SUBJECT_CLASS) ^= 0); class_sw.sender = (class_count (SENDER_CLASS) ^= 0); class_sw.recipient = (class_count (RECIPIENT_CLASS) ^= 0); /* Determine which messages are selected: If there are message specifiers, process them to get the initial set of eligible messages and then apply the selection control arguments, if any. If there are no message specifiers but there are selection control arguments, mark all messages as eligible and apply the control arguments. If there are no message specifiers and no selection control arguments, the list request defaults to all messages, the *_original requests default to those messages being processed by the reply/forward request, and the retrieve request aborts as it requires some specifier */ if msg_spec_count = 0 then /* no message specifiers */ if is_original_request & (string (class_sw) = ""b) then call rdm_message_mark_mgr_$remark_original_messages (rdm_invocation_ptr); else if request = LIST_REQUEST then call rdm_message_mark_mgr_$mark_all_messages (rdm_invocation_ptr, msg_type); else if request = RETRIEVE_REQUEST then /* must have some type of specification ... */ if string (class_sw) = ""b then /* ... and no selection control arguments */ call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "At least one message specifier is required for this request."); else call rdm_message_mark_mgr_$mark_all_messages (rdm_invocation_ptr, msg_type); else if request = OTHER_REQUEST then /* all, first, seen, first_seen, etc. */ call rdm_message_mark_mgr_$do_request (P_sci_ptr, rdm_invocation_ptr, other_keyword_type, msg_type, reverse_sw); else do; /* all other requests ... */ if string (class_sw) = ""b then call rdm_message_mark_mgr_$mark_current_message (rdm_invocation_ptr, msg_type); /* phx19099 RL - usage of "-odl" with current will be caught during marking */ else call rdm_message_mark_mgr_$mark_all_messages (rdm_invocation_ptr, msg_type); end; else call process_msg_specs (); /* process the message specifiers */ if (string (class_sw) ^= ""b) & case_independence_sw then call make_lowercase_select_strings (); /* user wants case independence: use lower-case */ if string (class_sw) ^= ""b then /* there are other selections to be performed */ call process_selections (marked_chain.n_messages); if marked_chain.n_messages = 0 & request ^= OTHER_REQUEST then call ssu_$abort_line (P_sci_ptr, 0, "No messages selected."); /* Perform the actual request */ if reverse_sw then do; /* process them in the opposite of the order marked */ first_message_idx = marked_chain.n_messages; last_message_idx = 1; message_idx_increment = -1; end; else do; /* process them in the order makred */ first_message_idx = 1; last_message_idx = marked_chain.n_messages; message_idx_increment = 1; end; if request = LIST_REQUEST then call perform_list_request (LIST_INFO); else if (request = PRINT_REQUEST) | (request = PRINT_HEADER_REQUEST) then do; call perform_printing_request (); if delete_sw then /* ... delete them after printing */ call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, "0"b); end; else if request = DELETE_REQUEST then call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, force_sw); else if request = RETRIEVE_REQUEST then call rdm_mailbox_interface_$retrieve_messages (rdm_invocation_ptr); else if request = SWITCH_OFF_REQUEST | request = SWITCH_ON_REQUEST then call set_switch (P_sci_ptr); else if request = OTHER_REQUEST then call perform_list_request (JUST_LIST_NUMBERS); call cleanup_request (); return; %page; /* The "mailbox" request: returns/prints the pathname of the mailbox being examined by read_mail */ mailbox_request: entry (P_sci_ptr, P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; call ssu_$return_arg (P_sci_ptr, n_arguments, active_request, return_value_ptr, return_value_max_lth); if n_arguments > 0 then call ssu_$abort_line (P_sci_ptr, 0, "No arguments are allowed."); mailbox_ptr = rdm_invocation.mailbox_ptr; if active_request then /* requote it in case it contains spaces */ return_value = requote_string_ (rtrim (pathname_ (mailbox.mailbox_dirname, mailbox.mailbox_ename))); else call ioa_ ("Reading: ^a", pathname_ (mailbox.mailbox_dirname, mailbox.mailbox_ename)); return; %page; /* Prepares to execute the request */ setup_request: procedure (); rdm_invocation_ptr = P_rdm_invocation_ptr; if rdm_invocation.type = SDM_INVOCATION then do; /*** Invoked from send_mail during a reply ... */ sdm_invocation_ptr = rdm_invocation_ptr; if (request ^= LIST_REQUEST) & (request ^= PRINT_REQUEST) & (request ^= PRINT_HEADER_REQUEST) then call ssu_$abort_line (P_sci_ptr, ssu_et_$unimplemented_request); else if sdm_invocation.rdm_invocation_ptr = null () then call ssu_$abort_line (P_sci_ptr, 0, "This request is valid only during a ""reply"" request."); is_original_request = "1"b; rdm_invocation_ptr = sdm_invocation.rdm_invocation_ptr; end; else if rdm_invocation.type = RDM_FORWARD_INVOCATION then do; /*** Invoked from the forward request sub-loop ... */ rdm_forward_invocation_ptr = rdm_invocation_ptr; if request ^= PRINT_REQUEST then /* ... only print_original for forward */ call ssu_$abort_line (P_sci_ptr, ssu_et_$unimplemented_request); is_original_request = "1"b; rdm_invocation_ptr = rdm_forward_invocation.rdm_invocation_ptr; end; else is_original_request = "0"b; /* normal read_mailish usage */ if request = LIST_REQUEST | request = OTHER_REQUEST then /* only one of these which can be an active request */ call ssu_$return_arg (P_sci_ptr, n_arguments, active_request, return_value_ptr, return_value_max_lth); else do; call ssu_$arg_count (P_sci_ptr, n_arguments); active_request = "0"b; /* ... won't hurt */ end; call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); msg_spec_count = 0; msg_type = NON_DELETED_MESSAGES; /* default value */ msg_spec_array_size = n_arguments; /* setup the array of message specifier argument indeces */ msg_spec_array_ptr = stack_allocate (currentsize (msg_spec_array)); n_selections = n_arguments; /* setup the array of selection specifications */ selection_array_ptr = stack_allocate (currentsize (selection_array)); saved_rdm_sci_ptr = rdm_invocation.sci_ptr; /* for cleanup handler */ selection_array.array (*).address_ptr = null (); /* ... */ n_selections = 0; /* haven't seen any selection control arguments yet */ class_count (*) = 0; case_independence_sw, delete_sw, force_sw, listing_header_sw, reverse_sw = "0"b; return; end setup_request; %page; /* Cleans up after the execution of one of these requests */ cleanup_request: procedure (); dcl idx fixed binary; do idx = 1 to n_selections; sel_ptr = addr (selection_array.array (idx)); if sel.address_ptr ^= null () then call mail_system_$free_address (sel.address_ptr, (0)); end; rdm_invocation.sci_ptr = saved_rdm_sci_ptr; return; end cleanup_request; /* Allocates an object by extending its caller's stack frame */ stack_allocate: procedure (p_size) returns (pointer) /* options (quick) */; dcl p_size fixed binary (19) parameter; dcl obj_ptr pointer; dcl code fixed binary (35); call cu_$grow_stack_frame (p_size, obj_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Unable to allocate ^d words of stack frame space.", p_size); return (obj_ptr); end stack_allocate; %page; /* Process the request line arguments */ process_arguments: procedure (); do argument_idx = first_argument to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") ^= 1 & request ^= OTHER_REQUEST then do; /* a message specifier ... */ msg_spec_count = msg_spec_count + 1; /* ... record its position for later */ msg_spec_array (msg_spec_count) = argument_idx; end; else if request = SWITCH_OFF_REQUEST | request = SWITCH_ON_REQUEST then call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else if ^dl_rt_sw & ((argument = "-reverse") | (argument = "-rv")) then reverse_sw = "1"b; else if ^dl_rt_sw & ((argument = "-no_reverse") | (argument = "-nrv")) then reverse_sw = "0"b; else if ^dl_rt_sw & ((argument = "-include_deleted") | (argument = "-idl")) then msg_type = ALL_MESSAGES; else if ^dl_rt_sw & ((argument = "-only_deleted") | (argument = "-odl")) then msg_type = ONLY_DELETED_MESSAGES; else if ^dl_rt_sw & ((argument = "-only_non_deleted") | (argument = "-ondl")) then msg_type = NON_DELETED_MESSAGES; else if request = OTHER_REQUEST then if index (argument, "-") ^= 1 then call ssu_$abort_line (P_sci_ptr, error_table_$badarg, "This request accepts only control arguments."); else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); /*** obsolete control arguments: remove support in MR11 */ else if ^dl_rt_sw & ((argument = "-all") | (argument = "-a")) then msg_type = ALL_MESSAGES; else if (argument = "-non_case_sensitive") | (argument = "-ncs") then case_independence_sw = "1"b; else if (argument = "-case_sensitive") | (argument = "-cs") then case_independence_sw = "0"b; else if (argument = "-subject") | (argument = "-sj") then do; call get_next_one_argument ("A string or a regular expression"); call get_selection (SUBJECT_CLASS); sel.type = SUBJECT_FIELD; /* which field to scan */ call add_string_or_regexp (argument1); end; else if (argument = "-in_reply_to") | (argument = "-irt") then do; call get_next_one_argument ("A string or a regular expression"); call get_selection (SUBJECT_CLASS); sel.type = IN_REPLY_TO_FIELD; /* which field to scan */ call add_string_or_regexp (argument1); end; else if (argument = "-between") | (argument = "-bt") then do; call get_next_two_arguments ("Two date/times"); call get_selection (TIME_CLASS); /* sel.type is irrelevant for TIME class */ sel.time_1 = convert_time (argument1, "1"b); sel.time_2 = convert_time (argument2, "1"b) + ONE_DAY; if sel.time_1 >= sel.time_2 then do; BETWEEN_TIMES_IN_WRONG_ORDER: call ssu_$abort_line (P_sci_ptr, 0, "The range of ^a ""^a"" ""^a"" is empty or backwards.", control_argument, argument1, argument2); end; end; else if (argument = "-between_times") | (argument = "-between_time") | (argument = "-btt") then do; call get_next_two_arguments ("Two date/times"); call get_selection (TIME_CLASS); /* sel.type is irrelevant for TIME class */ sel.time_1 = convert_time (argument1, "0"b); sel.time_2 = convert_time (argument2, "0"b); /* phx19118 RL - corrected direction of time comparison */ if sel.time_1 > sel.time_2 then go to BETWEEN_TIMES_IN_WRONG_ORDER; end; else if (argument = "-after") | (argument = "-af") then do; call get_next_one_argument ("A date/time"); call get_selection (TIME_CLASS); sel.time_1 = convert_time (argument1, "1"b); sel.time_2 = END_OF_TIME; end; else if (argument = "-after_time") | (argument = "-aft") then do; call get_next_one_argument ("A date/time"); call get_selection (TIME_CLASS); sel.time_1 = convert_time (argument1, "0"b); sel.time_2 = END_OF_TIME; end; else if (argument = "-before") | (argument = "-be") then do; call get_next_one_argument ("A date/time"); call get_selection (TIME_CLASS); sel.time_1 = BEGINNING_OF_TIME; sel.time_2 = convert_time (argument1, "1"b); end; else if (argument = "-before_time") | (argument = "-bet") then do; call get_next_one_argument ("A date/time"); call get_selection (TIME_CLASS); sel.time_1 = BEGINNING_OF_TIME; sel.time_2 = convert_time (argument1, "0"b); end; else if (argument = "-date") | (argument = "-dt") then do; call get_next_one_argument ("A date/time"); call get_selection (TIME_CLASS); sel.time_1 = convert_time (argument1, "1"b); sel.time_2 = sel.time_1 + ONE_DAY; end; else if (argument = "-from") | (argument = "-fm") then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (SENDER_CLASS); sel.type = FROM_FIELD; if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if (argument = "-reply_to") | (argument = "-rpt") then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (SENDER_CLASS); sel.type = REPLY_TO_FIELD; if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if argument = "-to" then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (RECIPIENT_CLASS); sel.type = TO_FIELD; if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if argument = "-cc" then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (RECIPIENT_CLASS); sel.type = CC_FIELD; if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if argument = "-bcc" then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (RECIPIENT_CLASS); sel.type = BCC_FIELD; if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if (argument = "-forwarded_to") | (argument = "-fwdt") then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (RECIPIENT_CLASS); sel.type = TO_FIELD + REDISTRIBUTED_FIELDS_BASE; if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if (argument = "-recipient") | (argument = "-rcp") then do; call get_next_one_argument ("An address or a regular expression"); call get_selection (RECIPIENT_CLASS); sel.type = -1; /* special -- indicates all recipient fields */ if index (argument1, SLASH) = 1 then call add_string_or_regexp (argument1); else call add_address (); end; else if request = PRINT_REQUEST then do; if ((argument = "-delete") | (argument = "-dl")) & ^is_original_request then delete_sw = "1"b; else if ((argument = "-no_delete") | (argument = "-ndl")) & ^is_original_request then delete_sw = "0"b; else if (argument = "-long_header") | (argument = "-lghe") then formatting_mode = LONG_FORMATTING_MODE; else if (argument = "-header") | (argument = "-he") then formatting_mode = DEFAULT_FORMATTING_MODE; else if (argument = "-brief_header") | (argument = "-bfhe") then formatting_mode = BRIEF_FORMATTING_MODE; else if (argument = "-no_header") | (argument = "-nhe") then formatting_mode = NONE_FORMATTING_MODE; /*** obsolete control arguments: delete in MR11 */ else if ((argument = "-header_only") | (argument = "-ho")) then do; formatting_mode = DEFAULT_FORMATTING_MODE; local_fmo.include_body = "0"b; end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); end; else if request = PRINT_HEADER_REQUEST then do; if ((argument = "-delete") | (argument = "-dl")) & ^is_original_request then delete_sw = "1"b; else if ((argument = "-no_delete") | (argument = "-ndl")) & ^is_original_request then delete_sw = "0"b; else if (argument = "-long") | (argument = "-lg") then formatting_mode = LONG_FORMATTING_MODE; else if (argument = "-default") | (argument = "-dft") then formatting_mode = DEFAULT_FORMATTING_MODE; else if (argument = "-brief") | (argument = "-bf") then formatting_mode = BRIEF_FORMATTING_MODE; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); end; else if request = LIST_REQUEST then do; if (argument = "-header") | (argument = "-he") then listing_header_sw = "1"b; else if (argument = "-no_header") | (argument = "-nhe") then listing_header_sw = "0"b; else if (argument = "-line_length") | (argument = "-ll") then do; call get_next_one_argument ("A number"); listing_line_length = cv_dec_check_ (argument1, code); if code ^= 0 then INVALID_LINE_LENGTH_SPECIFICATION: call ssu_$abort_line (P_sci_ptr, 0, "Line length must be a number not less than 60; not ""^a"".", argument1); if listing_line_length < 60 then go to INVALID_LINE_LENGTH_SPECIFICATION; end; else if (argument = "-no_line_length") | (argument = "-nll") then listing_line_length = -1; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); end; else if request = DELETE_REQUEST then do; if (argument = "-force") | (argument = "-fc") then force_sw = "1"b; else if (argument = "-no_force") | (argument = "-nfc") then force_sw = "0"b; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); end; return; %page; /* Internal to process_arugments: fetches the next argument and complains if it's not there */ get_next_one_argument: procedure (p_expected); dcl p_expected character (*) parameter; if (argument_idx + 1) > n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "^a after ""^a"".", p_expected, control_argument) ; argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument1_ptr, argument1_lth); return; end get_next_one_argument; /* Inernal to process_arguments: fetches the next two arguments and complains if either is not there */ get_next_two_arguments: procedure (p_expected); dcl p_expected character (*) parameter; if (argument_idx + 2) > n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "^a after ""^a"".", p_expected, control_argument) ; argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument1_ptr, argument1_lth); argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument2_ptr, argument2_lth); return; end get_next_two_arguments; %page; /* Internal to process_arguments: gets the next selection_array entry: initializes it, increments the per-class counter, and sets sel_ptr */ get_selection: procedure (p_class); dcl p_class fixed binary parameter; n_selections = n_selections + 1; sel_ptr = addr (selection_array.array (n_selections)); unspec (sel) = ""b; sel.class = p_class; sel.str_ptr = null (); sel.address_ptr = null (); class_count (p_class) = class_count (p_class) + 1; return; end get_selection; %page; /* Internal to process_arguments: makes the current selection a string or regular expression selection based on the whether the first character of the string is not or is a slash (/), respectively */ add_string_or_regexp: procedure (p_string); dcl p_string character (*) parameter; dcl search_string character (sel.str_lth) unaligned based (sel.str_ptr); sel.regexp_sw = (index (p_string, SLASH) = 1); if sel.regexp_sw then do; /* a regular expression */ if substr (p_string, length (p_string), 1) ^= SLASH then call ssu_$abort_line (P_sci_ptr, 0, "Missing regular expression delimiter. ^a ""^a""", control_argument, p_string); sel.str_ptr = addcharno (addr (p_string), 1); sel.str_lth = length (p_string) - 2; /* ... excluding the slashes */ end; else do; /* a string to be matched exactly */ sel.str_ptr = addr (p_string); sel.str_lth = length (p_string); end; if verify (search_string, WHITESPACE) = 0 then /* can't be empty */ call ssu_$abort_line (P_sci_ptr, mlsys_et_$null_search_string, "After ""^a"".", control_argument); if sel.regexp_sw then do; /* insure that it has proper syntax */ call search_file_$silent (sel.str_ptr, 1, sel.str_lth, addr (NULL_STRING), 1, 0, (0), (0), code); if code = error_table_$nomatch then /* ... can only get this if the expression's syntax is OK */ code = 0; if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a ""^a""", control_argument, p_string); end; return; end add_string_or_regexp; %page; /* Internal to process_arguments: converts a date/time string and optionally truncates to midnight */ convert_time: procedure (p_time, p_adjust_sw) returns (fixed binary (71)); dcl p_time character (*) parameter; dcl p_adjust_sw bit (1) aligned parameter; dcl clock_value fixed binary (71); dcl (month, day_of_month, year) fixed binary; dcl time_zone character (3); dcl code fixed binary (35); call convert_date_to_binary_ (p_time, clock_value, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a ""^a""", control_argument, p_time); if p_adjust_sw then do; /* truncate to the previous midnight */ time_zone = ""; /* must be initialized */ call decode_clock_value_$date_time (clock_value, month, day_of_month, year, (0), (0), (0), (0), (0), time_zone, (0)); call encode_clock_value_ (month, day_of_month, year, 0, 0, 0, 0, 0, time_zone, clock_value, (0)); end; return (clock_value); end convert_time; %page; /* Internal to process_arguments: collects a single address from the argument list */ add_address: procedure (); dcl 1 local_pcao aligned like parse_ca_options; dcl code fixed binary (35); local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode, local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = "1"b; local_pcao.validate_addresses = "0"b; local_pcao.mbz = ""b; call mlsys_utils_$parse_address_control_args (P_sci_ptr, argument_idx, addr (local_pcao), sel.address_ptr, code); if code ^= 0 then /* ... only fatal errors will get here */ call ssu_$abort_line (P_sci_ptr, code, "Parsing control arguments."); argument_idx = argument_idx - 1; /* do loop will increment this again ... */ return; end add_address; end process_arguments; %page; /* Marks the messages selected by the message specifiers */ process_msg_specs: procedure (); dcl idx fixed binary; do idx = 1 to msg_spec_count; call ssu_$arg_ptr (P_sci_ptr, msg_spec_array (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, msg_type, ""b, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code); end; return; end process_msg_specs; %page; /* Converts all selection strings to lowercase for case independent searching: The lowercase version of the strings are allocated on our caller's stack */ make_lowercase_select_strings: procedure () /* options (quick) */; dcl sel_str character (sel.str_lth) based (sel.str_ptr); dcl copy_str character (copy_str_lth) based (copy_str_ptr); dcl copy_str_lth fixed binary (21); dcl copy_str_ptr pointer; dcl idx fixed binary; do idx = 1 to n_selections; sel_ptr = addr (selection_array.array (idx)); if sel.str_ptr ^= null () then do; /* there's a string */ copy_str_lth = sel.str_lth; copy_str_ptr = stack_allocate (divide ((copy_str_lth + 3), 4, 18, 0)); copy_str = translate (sel_str, LOWERCASE, UPPERCASE); sel.str_ptr = copy_str_ptr; /* ... replace it by the all lowercase copy */ end; end; return; end make_lowercase_select_strings; %page; /* Processes the message selection control arguments */ process_selections: procedure (p_message_count) options (non_quick); dcl p_message_count fixed binary parameter; dcl time_bits (p_message_count) bit (1) unaligned automatic; dcl subject_bits (p_message_count) bit (1) unaligned automatic; dcl sender_bits (p_message_count) bit (1) unaligned automatic; dcl recipient_bits (p_message_count) bit (1) unaligned automatic; dcl new_marked_bits (p_message_count) bit (1) unaligned automatic; dcl 1 buffer aligned based, /* used for following like clauses */ 2 text_ptr pointer, 2 text_lth fixed binary (21); dcl 1 message_field_buffers aligned, /* used to reduce # of calls to mlsys_utils_$format... */ 2 in_reply_to like buffer, 2 from like buffer, 2 reply_to like buffer, 2 to like buffer, 2 cc like buffer, 2 bcc like buffer; dcl 1 matched_sw aligned like class_sw; /* for determining when we may stop looking at selections */ dcl 1 saved_last_search_buffer aligned like rdm_invocation.last_search_buffer; dcl code fixed binary (35); dcl (message_idx, message_number, selection_idx, idx) fixed binary; new_marked_bits (*) = "1"b; /* assume everything matches */ if class_sw.time then string (time_bits) = ""b; if class_sw.subject then string (subject_bits) = ""b; if class_sw.sender then string (sender_bits) = ""b; if class_sw.recipient then string (recipient_bits) = ""b; saved_last_search_buffer = rdm_invocation.last_search_buffer; on condition (cleanup) begin; if saved_last_search_buffer.buffer_ptr = rdm_invocation.last_search_buffer.buffer_ptr then rdm_invocation.last_search_buffer = saved_last_search_buffer; end; /* Process the selections: a message is selected if it matches all classes with non-zero selection specifications; only one specification in a class must match to say that message matches the class */ do message_idx = 1 to marked_chain.n_messages; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); message_field_buffers.in_reply_to.text_ptr, /* haven't contructed any printed representations yet */ message_field_buffers.from.text_ptr, message_field_buffers.reply_to.text_ptr, message_field_buffers.to.text_ptr, message_field_buffers.cc.text_ptr, message_field_buffers.bcc.text_ptr = null (); string (matched_sw) = ""b; /* not matched yet */ do selection_idx = 1 to n_selections; sel_ptr = addr (selection_array.array (selection_idx)); if sel.class = TIME_CLASS then call process_time_selection (); else if sel.class = SUBJECT_CLASS then call process_subject_selection (); else if sel.class = SENDER_CLASS then call process_sender_selection (); else if sel.class = RECIPIENT_CLASS then call process_recipient_selection (); end; CHECK_NEXT_MESSAGE: /* control transfers here if message matches completely */ if saved_last_search_buffer.buffer_ptr = rdm_invocation.last_search_buffer.buffer_ptr then rdm_invocation.last_search_buffer = saved_last_search_buffer; end; if class_sw.time then string (new_marked_bits) = string (new_marked_bits) & string (time_bits); if class_sw.subject then string (new_marked_bits) = string (new_marked_bits) & string (subject_bits); if class_sw.sender then string (new_marked_bits) = string (new_marked_bits) & string (sender_bits); if class_sw.recipient then string (new_marked_bits) = string (new_marked_bits) & string (recipient_bits); /* Remove all those messages from the marked chain which did not match the selection criteria */ do message_idx = marked_chain.n_messages to 1 by -1; if ^new_marked_bits (message_idx) then do; /* delete this one */ do idx = (message_idx + 1) to marked_chain.n_messages; marked_chain.messages (idx - 1) = marked_chain.messages (idx); end; marked_chain.n_messages = marked_chain.n_messages - 1; end; end; return; %page; /* Internal to process_selections: processes a single time selection for the current message */ process_time_selection: procedure (); if matched_sw.time then return; /* already matched one of the time criteria */ if (message.date_time_created >= sel.time_1) & (message.date_time_created <= sel.time_2) then do; time_bits (message_idx) = "1"b; /* it matches */ matched_sw.time = "1"b; end; if string (matched_sw) = string (class_sw) then go to CHECK_NEXT_MESSAGE; /* stop when all criteria are met */ return; end process_time_selection; %page; /* Internal to process_selections: processes a single text field (Subject/In-Reply-To) selection: either substring or regular expression match */ process_subject_selection: procedure (); if matched_sw.subject then return; /* already matched a subject criteria */ if sel.type = SUBJECT_FIELD then /* check the message subject */ if match_sel_on_string (message.subject.text_ptr, message.subject.text_lth) then do; subject_bits (message_idx) = "1"b; /* ... it matches */ matched_sw.subject = "1"b; end; else ; else /*** if sel.type = IN_REPLY_TO_FIELD then */ /*** don't bother if there's no In-Reply-To field */ if message.n_reply_references > 0 then do; if message_field_buffers.in_reply_to.text_ptr = null () then call rdm_search_utils_$prepare_message_references_field_for_search (rdm_invocation_ptr, message_number, REPLY_REFERENCES_FIELDNAME, message.reply_references, message_field_buffers.in_reply_to.text_ptr, message_field_buffers.in_reply_to.text_lth); if match_sel_on_string (message_field_buffers.in_reply_to.text_ptr, message_field_buffers.in_reply_to.text_lth) then do; subject_bits (message_idx) = "1"b; matched_sw.subject = "1"b; end; end; if string (matched_sw) = string (class_sw) then go to CHECK_NEXT_MESSAGE; return; end process_subject_selection; %page; /* Internal to process_selections: processes a single sender field (From/Reply-To) selection: either a regular expression or an address match */ process_sender_selection: procedure (); if matched_sw.sender then return; /* already satisfied a sender selection */ if sel.type = FROM_FIELD then call process_address_list_selection (FROM_FIELDNAME, message.from, message_field_buffers.from, sender_bits, matched_sw.sender); else /*** if sel.type = REPLY_TO_FIELD then */ call process_address_list_selection (REPLY_TO_FIELDNAME, message.reply_to, message_field_buffers.reply_to, sender_bits, matched_sw.sender); return; end process_sender_selection; %page; /* Internal to process_selections: processes a single recipient field (To/cc/bcc/Redistributed-To) selection: either a regular expression or an address match */ process_recipient_selection: procedure (); if matched_sw.recipient then return; /* already matched a recipient selection */ if sel.type = -1 then do; /* special case: all recipients */ call process_single_recipient_selection (TO_FIELD); call process_single_recipient_selection (CC_FIELD); call process_single_recipient_selection (BCC_FIELD); call process_single_recipient_selection ((TO_FIELD + REDISTRIBUTED_FIELDS_BASE)); end; else call process_single_recipient_selection (sel.type); return; /* Internal to process_recipients_selection: actually processes the selection */ process_single_recipient_selection: procedure (p_field_type); dcl p_field_type fixed binary parameter; dcl 1 redistributed_buffer aligned like buffer; dcl redistributed_fieldname character (64) varying; dcl idx fixed binary; if p_field_type = TO_FIELD then call process_address_list_selection (TO_FIELDNAME, message.to, message_field_buffers.to, recipient_bits, matched_sw.recipient); if p_field_type = CC_FIELD then call process_address_list_selection (CC_FIELDNAME, message.cc, message_field_buffers.cc, recipient_bits, matched_sw.recipient); if p_field_type = BCC_FIELD then call process_address_list_selection (BCC_FIELDNAME, message.bcc, message_field_buffers.bcc, recipient_bits, matched_sw.recipient); else /*** if p_field_type = (TO_FIELD + REDISTRIBUTED_FIELDS_BASE) then */ if message.n_redistributions > 0 then do; redistributed_fieldname = REDISTRIBUTED_PREFIX || TO_FIELDNAME; do idx = 1 to message.n_redistributions; redistributed_buffer.text_ptr = null (); call process_address_list_selection (redistributed_fieldname, message_redistributions_list.redistributions (idx).to, redistributed_buffer, recipient_bits, matched_sw.recipient); end; end; return; end process_single_recipient_selection; end process_recipient_selection; %page; /* Internal to process_selections: performs a selection over the given address list */ process_address_list_selection: procedure (p_fieldname, p_address_list_ptr, p_list_buffer, p_matched_bits_array, p_matched_type_sw); dcl p_fieldname character (*) varying parameter; dcl p_address_list_ptr pointer parameter; dcl 1 p_list_buffer aligned parameter like buffer; dcl p_matched_bits_array (*) bit (1) unaligned parameter; dcl p_matched_type_sw bit (1) unaligned parameter; dcl address_idx fixed binary; if is_empty_list (p_address_list_ptr) then ; /* don't bother if it's emtpy */ else do; if sel.regexp_sw then do; /* match against the printed representation */ if p_list_buffer.text_ptr = null () then call rdm_search_utils_$prepare_address_list_field_for_search (rdm_invocation_ptr, message_number, p_fieldname, p_address_list_ptr, p_list_buffer.text_ptr, p_list_buffer.text_lth); if match_sel_on_string (p_list_buffer.text_ptr, p_list_buffer.text_lth) then go to FOUND_MATCHING_ADDRESS; end; else do; /* compare individual addresses */ do address_idx = 1 to p_address_list_ptr -> address_list.n_addresses; if mail_system_$compare_addresses (sel.address_ptr, p_address_list_ptr -> address_list.addresses (address_idx), (0)) then go to FOUND_MATCHING_ADDRESS; end; end; end; return; /* control reaches here iff there's no match */ /* Control arrives here iff a match was found in the address list */ FOUND_MATCHING_ADDRESS: p_matched_bits_array (message_idx) = "1"b; p_matched_type_sw = "1"b; if string (matched_sw) = string (class_sw) then go to CHECK_NEXT_MESSAGE; return; end process_address_list_selection; %page; /* Internal to process_selections: matches the string either against a substring or a regular expression */ match_sel_on_string: procedure (p_str_ptr, p_str_lth) returns (bit (1) aligned); dcl p_str_ptr pointer parameter; dcl p_str_lth fixed binary (21) parameter; dcl sel_str character (sel.str_lth) unaligned based (sel.str_ptr); dcl match_str character (match_str_lth) based (match_str_ptr); dcl match_str_lth fixed binary (21); dcl match_str_ptr pointer; dcl match_sw bit (1) aligned; dcl code fixed binary (35); match_str_ptr = p_str_ptr; match_str_lth = p_str_lth; /* If case independence is requested, copy the string onto the stack and convert it to lower case */ if case_independence_sw then begin options (non_quick); dcl copied_str character (match_str_lth) automatic; copied_str = translate (match_str, LOWERCASE, UPPERCASE); if sel.regexp_sw then do; call search_file_$silent (sel.str_ptr, 1, sel.str_lth, addr (copied_str), 1, match_str_lth, (0), (0), code); match_sw = (code = 0); end; else match_sw = (index (copied_str, sel_str) ^= 0); end; /* Normal case sensitive check */ else do; if sel.regexp_sw then do; call search_file_$silent (sel.str_ptr, 1, sel.str_lth, match_str_ptr, 1, match_str_lth, (0), (0), code); match_sw = (code = 0); end; else match_sw = (index (match_str, sel_str) ^= 0); end; return (match_sw); end match_sel_on_string; end process_selections; %page; /* Lists the selected messages */ perform_list_request: procedure (P_list_sw); dcl P_list_sw bit (1) aligned; dcl (is_non_deleted, return_one_sw, seen_old_current_message) bit (1) aligned; dcl (old_current_message, new_current_message) fixed binary; dcl message_number_picture picture "(8)z9"; if active_request then return_value = ""; /* initialize output */ else do; /* displaying on the terminal ... */ if P_list_sw = JUST_LIST_NUMBERS then do; output_line_length = min (maxlength (output_buffer), get_line_length_$switch (iox_$user_output, (0))); output_buffer = ""; end; else if listing_header_sw then do; call mlsys_utils_$print_message_summary_header (listing_line_length, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Printing listing header line."); end; end; seen_old_current_message = "0"b; /* assume current message isn't going to be listed */ old_current_message = rdm_invocation.current_message; new_current_message = 0; /* Determine which message will be "current" after the list request completes: if the current message is listed, it will remain the current message; otherwise, the first non-deleted message will become current */ do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); is_non_deleted = "1"b; /* ... examine the deleted chain */ do idx = 1 to deleted_chain.n_messages while (is_non_deleted); if deleted_chain.messages (idx) = message_number then is_non_deleted = "0"b; end; if is_non_deleted then /* ... it's not been deleted */ if new_current_message = 0 then new_current_message = message_number; if message_number = old_current_message then seen_old_current_message = "1"b; end; if seen_old_current_message then /* present current message is in the list: it stays current */ new_current_message = old_current_message; else /* present current message isn't being listed ... */ if new_current_message = 0 then /* ... but all the listed messages are deleted: status quo */ new_current_message = old_current_message; /* Actually list the messages */ do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); if active_request then do; /* just return the message number */ if length (return_value) > 0 then return_value = return_value || " "; return_value = return_value || ltrim (convert (message_number_picture, message_number)); end; else if P_list_sw = JUST_LIST_NUMBERS then do; /* just print the message numbers (seen, etc.) */ message_number_string = ltrim (convert (message_number_picture, message_number)); if (length (output_buffer) + length (message_number_string) + 1) > output_line_length then do; call ioa_ ("^a", output_buffer); output_buffer = ""; end; if output_buffer ^= "" then output_buffer = output_buffer || " "; output_buffer = output_buffer || message_number_string; end; else call list_single_message (); /* display the summary */ end; if P_list_sw = JUST_LIST_NUMBERS then do; return_one_sw = (request = OTHER_REQUEST & other_keyword_type ^= ALL_KEYWORD & other_keyword_type ^= SEEN_KEYWORD & other_keyword_type ^= UNSEEN_KEYWORD & other_keyword_type ^= NEW_KEYWORD); if active_request then do; if return_value = "" & return_one_sw then return_value = "0"; /* default for "first", etc. if no message */ end; else do; if output_buffer = "" & return_one_sw then output_buffer = "0"; if ^active_request then call ioa_ ("^a", output_buffer); end; end; /* phx20589 RL - change current message only if not active request; */ /* also check that set_new_current_msg is called with a non-zero new */ /* current message since we don't want to change the current message */ /* if it's zero and the call to set_new_current_msg may do that */ if ^active_request & new_current_message ^= 0 then call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, new_current_message, rdm_invocation.current_message); return; /* Internal to perform_list_request: lists a single message */ list_single_message: procedure (); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); call mlsys_utils_$print_message_summary (message_ptr, message_number, (message_number = new_current_message), listing_line_length, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Printing listing of message #^d.", message_number); call rdm_mailbox_interface_$mark_processed (rdm_invocation_ptr, message_number); return; end list_single_message; end perform_list_request; %page; /* Prints the selected messages: implements the guts of the print and print_header requests */ perform_printing_request: procedure (); if formatting_mode = BRIEF_FORMATTING_MODE then local_fmo.envelope_formatting_mode = NONE_FORMATTING_MODE; else local_fmo.envelope_formatting_mode = formatting_mode; local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = formatting_mode; do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); /* phx18564 RL - set current message to message_number only if it is not a deleted message; otherwise current set to next non-deleted message after message_number */ call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, message_number, rdm_invocation.current_message); /* it's current while we're printing it */ /*** following ioa_ call is OK until messages appear with sections that aren't preformatted */ call ioa_ ("^/ #^d^[ (^d line^[s^] in body)^]:", message_number, (message.total_lines ^= -1), message.total_lines, (message.total_lines ^= 1)); call mlsys_utils_$print_message (message_ptr, addr (local_fmo), iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print message #^d.", message_number); call ioa_ (" ---(^d)---", message_number); call iox_$control (iox_$user_output, "reset_more", null (), (0)); call rdm_mailbox_interface_$mark_processed_and_acknowledge (rdm_invocation_ptr, message_number); if request = PRINT_REQUEST then call mail_system_$set_message_switch (message_ptr, PER_MESSAGE_SEEN_SWITCH_TYPE, "1"b, (0)); end; return; end perform_printing_request; %page; set_switch: proc (P_sci_ptr); dcl P_sci_ptr ptr; dcl switch_value bit (1) aligned; if request = SWITCH_OFF_REQUEST then switch_value = "0"b; else switch_value = "1"b; do message_idx = first_message_idx to last_message_idx by message_idx_increment; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); call mail_system_$set_message_switch (message_ptr, switch_type, switch_value, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Setting switch on message ^d", message_number); end; return; end set_switch; %page; /* Determines if the supplied address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* no data at all */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include rdm_msg_spec_keywords; %page; %include rdm_switch_types; %page; %include sdm_invocation; %page; %include rdm_fwd_invocation; %page; %include mlsys_format_options; %page; %include mlsys_parse_ca_options; %page; %include mlsys_field_names; %page; %include mlsys_mailbox; %page; %include mlsys_field_types; %page; %include mlsys_message; %page; %include mlsys_address_list; %page; /* The standard definition of whitespace on Multics */ dcl WHITESPACE character (5) static options (constant) initial (" "); /* SP HT NL VT FF */ end rdm_msg_requests_;  rdm_reply_request_.pl1 10/02/89 0908.5rew 10/02/89 0815.0 456930 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-07,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx19099, phx15783, Mail 457 - added message_type parameter to call to rdm_message_mark_mgr_$mark_current_message to catch use of "-odl" with the current message. 2) change(89-04-11,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx18564, phx17540, phx17353, Mail 446 - the new entry set_new_current_msg in rdm_mailbox_interface_ is now called when the current message is changed to guarantee that the new current message is never a deleted message; reformatting. END HISTORY COMMENTS */ /* format: off */ /* The read_mail reply request */ /* Created: March 1979 by W. Olin Sibert */ /* Modified: 25 December 1979 by W. Olin Sibert to update for new rdm_invocation, add new options, and fix bug in replying to a message with only a Sender: field */ /* Modified: 25 April 1980 by G. Palter to implement suggestion #084 -- Provide abbrev expansion of read_mail and send_mail request lines; add the "-abbrev", "-no_abbrev", and "-profile" control arguments */ /* Modified: 30 May 1980 by G. Palter to: (1) fix bug #0156 -- the "reply" request does not work on headerless messages; (2) implement suggestion #0309 -- the "reply" request should default the send_mail it creates to the same state of abbrev processing and the same profile as the read_mail invocation in which "reply" is executed; (3) implement suggestion #0263 -- the current message in read_mail should be set to the message being processed - thus, if an error occurs, the current message will remain on which the error occured; (4) implement suggestion #0184 -- when replying to a single address, the message should say "Replying to ADDRESS." - actually, it will include as many addresses as possible */ /* Modified: 31 May 1980 by G. Palter to: (1) implement suggestion #0220 -- the "-include_original" control argument to "reply" should also cause the inclusion of the From, Date and Subject fields; (2) implement suggestion #0186 -- there should be a "print_original" request in send_mail which prints the message being replied to when invoked by read_mail's "reply" request; (3) implement suggestion #0196 -- replying to an interactive message should cause the text of the message to be included (unless "-no_include_original" is given) */ /* Modified: 3 June 1980 by G. Palter to implement suggestion #0286 -- add control arguments to the "reply" request to suppress replying to yourself ("-no_include_self"). Make this argument the default */ /* Modified: 4 June 1980 by G. Palter to implement suggestion #0287 -- if a reply is being created and the user exits send_mail without sending the reply, the "-delete" control argument of the "reply" request should be ignored */ /* Modified: 17 June 1980 by G. Palter to: (1) fix bug #0326 -- Attempting to reply to a message sent by yourself when "-no_include_self" is in effect produces an error message and then sets the current message to garbage, causing all sorts of subsequent bad behavior; (2) partially implement suggestion #0327 -- The "reply" request should issue a warning when it detects that you would have been a recipient to a reply if "-no_include_self" had not been used */ /* Modified: 20 June 1980 by G. Palter to: (1) fix bug #0328 -- the "Replying to ..." message is ungramatical. It includes commas in the wrong places and also says "1 others" */ /* Modified: 24 July 1980 by G. Palter to add "-prompt" and "-no_prompt" control arguments */ /* Modified: 16 February 1982 by G. Palter for new calling sequences of ssu_$get_abbrev_info and ssu_$set_abbrev_info */ /* Modified: 19 September 1982 by G. Palter for new send_mail filling, prompting, and request loop control and to propogate the state of debug_mode to the created send_mail */ /* Modified: 2 November 1982 by G. Palter to: (1) insure that all foreign recipients have their host names validated; (2) fix mail_system error #0301 -- if all recipients of the reply are deleted because of errors, an extra message will be issued promising that the send_mail request loop will be entered; (3) fix mail_system error #0372 -- use of "-refill" without "-include_original" should be an error; (4) fix mail_system error #0330 -- the reply request doesn't count "-log" as a recipient causing improper rejection of reply requests if only the logbox is the recipient; and (5) implement mail_system suggestion #0327 -- the reply request should issue warnings when the reply would not be sent to the user as a result of the use of -no_include_self */ /* Modified: 7 November 1982 by G. Palter to: (1) fix mail_system error #0407 -- the reply request takes a null_pointer fault if one of the header fields used to determine the recipients of the reply (eg: From, To, cc) is empty; and (2) not issue the -no_include_self warning if "-nis" is given explicitly on either the read_mail command line or the reply request line */ /* Modified: 20 December 1982 by G. Palter to fix mail_system error #0408 -- the reply request does not recognize "-include_deleted", "-only_deleted", and "-only_non_deleted" */ /* Modified: October 1983 by G. Palter as part of the conversion to the new mail system interface */ /* Modified: March 1984 by G. Palter to fix the following mail system errors: #0421 -- the warning issued by the reply request when the "-no_include_self" default causes a copy of the reply not to be sent to the user is incorrect. It mistakenly claims that the default is "-include_self" #0433 -- the send_mail command and all send_mail and read_mail requests which accept multiple addresses as arguments do not properly parse "-log -at HOST" */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ rdm_reply_request_: procedure (P_sci_ptr, P_rdm_invocation_ptr); return; /* not an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_rdm_invocation_ptr pointer parameter; dcl argument character (argument_lth) based (argument_ptr); dcl argument_lth fixed binary (21); dcl argument_ptr pointer; dcl (n_arguments, argument_idx) fixed binary; dcl msg_spec_array (msg_spec_array_size) fixed binary based (msg_spec_array_ptr); dcl msg_spec_array_ptr pointer; dcl (msg_spec_array_size, msg_spec_count) fixed binary; dcl msg_type fixed binary; /* type of messages to process (all/undeleted/deleted) */ dcl input_filename character (input_filename_lth) unaligned based (input_filename_ptr); dcl (input_filename_ptr, input_file_ptr) pointer; dcl input_filename_lth fixed binary (21); dcl profile_pathname character (profile_pathname_lth) unaligned based (profile_pathname_ptr); dcl profile_dirname character (168); dcl profile_ename character (32); dcl (profile_pathname_ptr, profile_ptr) pointer; dcl profile_pathname_lth fixed binary (21); dcl (profile_pathname_given, abbrev_ca_given, abbrev_enabled) bit (1) aligned; dcl recipients_lists_array (3) pointer based (addr (sdm_subsystem_info.to)); dcl current_address_list_ptr pointer based (current_address_list_ptr_ptr); dcl current_address_list_ptr_ptr pointer; dcl sdm_invocation_ptr pointer; /* -> description of the send_mail invocation we created */ dcl 1 local_pcao aligned like parse_ca_options; dcl clear_original_message_chain bit (1) aligned; /* ON => we've marked the original messages */ dcl saved_current_message fixed binary; /* current message number before invokeing send_mail */ dcl include_authors_arg fixed binary (1); /* indicates if either -iat/-niat is on the request line */ dcl include_authors bit (1) aligned; /* ON => include the authors as recipients of the reply */ dcl to_arg_specified bit (1) aligned; /* ON => explicit primary recipients given: disable -iat */ dcl include_recipients bit (1) aligned; /* ON => include original recipients as reply recipients */ dcl include_self bit (1) aligned; /* ON => remove the user from implicit recipients */ dcl dont_issue_nis_warning bit (1) aligned; /* ON => don't complain if user is excluded */ dcl warning_given_for_this_message bit (1) aligned; /* ON => already complained for the current message */ dcl abort bit (1) aligned; /* ON => abort request if invalid address on request line */ dcl found_invalid_address bit (1) aligned; /* ... tracks invalid addresses */ dcl delete_after_processing bit (1) aligned; /* ON => delete original messages after the reply */ dcl address_ptr pointer; dcl my_person_id character (32); dcl compare_both_user_addresses bit (1) aligned; /* ON => mail table & default mailbox addresses differ */ dcl (message_idx, message_number) fixed binary; dcl recipient_count fixed binary; /* total # of recipients */ dcl code fixed binary (35); /* format: off */ dcl (DEFAULT_INCLUDE_AUTHORS initial (0), /* include authors if no explicit primary recipients */ INCLUDE_AUTHORS initial (1), /* include authors regardless */ NO_INCLUDE_AUTHORS initial (-1)) /* never include authors */ fixed binary (1) static options (constant); dcl (emf_et_$send_mail_aborted, error_table_$bad_conversion, error_table_$badopt, error_table_$inconsistent, error_table_$noarg, error_table_$smallarg, mlsys_et_$ca_parse_failed, mlsys_et_$no_recipients) fixed binary (35) external; /* format: on */ dcl iox_$user_output pointer external; dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl get_line_length_$switch entry (pointer, fixed binary (35)) returns (fixed binary); dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl mail_system_$add_address entry (pointer, pointer, character (8), fixed binary (35)); dcl mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned); dcl mail_system_$eliminate_duplicate_addresses entry ((*) pointer, fixed binary (35)); dcl mail_system_$free_address entry (pointer, fixed binary (35)); dcl mail_system_$free_address_list entry (pointer, fixed binary (35)); dcl mail_system_$merge_address_lists entry (pointer, pointer, bit (1) aligned, pointer, fixed binary (35)); dcl mail_system_$validate_address entry (pointer, bit (1) aligned, fixed binary (35)); dcl mlsys_utils_$parse_address_control_args entry (pointer, fixed binary, pointer, pointer, fixed binary (35)); dcl mlsys_utils_$parse_address_list_control_args entry (pointer, fixed binary, pointer, character (8), pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_validate_results entry (pointer, pointer, fixed binary (35)); dcl mlsys_utils_$summarize_address entry (pointer, bit (1) aligned, character (*) varying, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl rdm_mailbox_interface_$delete_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$mark_processed_and_acknowledge entry (pointer, fixed binary); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_mailbox_interface_$set_new_current_msg entry (ptr, fixed binary, fixed binary); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$clear_original_messages entry (pointer); dcl rdm_message_mark_mgr_$mark_current_message entry (pointer, fixed binary); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$mark_original_messages entry (pointer); dcl sdm_subsystem_$create_invocation entry (character (8), pointer, pointer, fixed binary (35)); dcl sdm_subsystem_$destroy_invocation entry (pointer, pointer); dcl sdm_subsystem_$subsystem entry (pointer, pointer, fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$print_message entry () options (variable); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl user_info_ entry (character (*)); dcl cleanup condition; dcl (addr, convert, currentsize, hbound, index, length, ltrim, maxlength, min, null, substr, translate) builtin; %page; reply_request: entry (P_sci_ptr, P_rdm_invocation_ptr); rdm_invocation_ptr = P_rdm_invocation_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); sdm_invocation_ptr, /* for cleanup handler */ sdm_subsystem_info_ptr, address_ptr, input_file_ptr, profile_ptr = null (); clear_original_message_chain = "0"b; on condition (cleanup) call cleanup_after_reply_request (); /* Create the send_mail invocation: This must be done before argument processing as the address lists in the sdm_subsystem_info structure are used directly */ call sdm_subsystem_$create_invocation (SDM_SUBSYSTEM_INFO_VERSION_6, sdm_invocation_ptr, sdm_subsystem_info_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Creating a send_mail subsystem."); sdm_subsystem_info.rdm_invocation_ptr = rdm_invocation_ptr; call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); msg_spec_count = 0; msg_type = NON_DELETED_MESSAGES; /* default value */ msg_spec_array_size = n_arguments; call cu_$grow_stack_frame (currentsize (msg_spec_array), msg_spec_array_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, 0, "Too many message specifiers on the request line."); /* Setup defaults: reading the user's profile will go here someday */ abort = "1"b; /* abort if any invalid addresses are on the request line */ found_invalid_address = "0"b; /* ... will need to know this later on */ delete_after_processing = "0"b; /* do not delete them after the reply is sent */ sdm_subsystem_info.debug = rdm_invocation.debug_mode; sdm_subsystem_info.include_original_text = rdm_invocation.reply_options.include_original; sdm_subsystem_info.original_text_indentation = -1;/* indicates "-indent" not seen */ include_authors_arg = DEFAULT_INCLUDE_AUTHORS; /* default is dependent on use of "-to" */ include_recipients = rdm_invocation.reply_options.include_recipients; to_arg_specified = "0"b; /* haven't seen explicit primary recipients */ if rdm_invocation.reply_options.include_self = DEFAULT_INCLUDE_SELF then include_self, dont_issue_nis_warning = "0"b; else if rdm_invocation.reply_options.include_self = INCLUDE_SELF then include_self, dont_issue_nis_warning = "1"b; else do; /* explicit -no_include_self on read_mail command line */ include_self = "0"b; dont_issue_nis_warning = "1"b; /* ... so suppress the warnings */ end; sdm_subsystem_info.fill_control = rdm_invocation.reply_options.fill_control; sdm_subsystem_info.fill_width = rdm_invocation.reply_options.line_length; abbrev_ca_given = "0"b; /* haven't seen -ab/-nab: use read_mail abbrev state */ profile_pathname_given = "0"b; /* no -profile yet */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = CREATE_AND_ANNOUNCE_MAILBOX; local_pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX; local_pcao.abort_on_errors = "0"b; /* can't abort in case -no_abort appears somewhere */ local_pcao.validate_addresses = "1"b; /* always check validity of addresses */ local_pcao.mbz = ""b; argument_idx = 1; current_address_list_ptr_ptr = null (); /* start out looking for msg-specs, rather than addresses */ /* Process arguments */ do while (argument_idx <= n_arguments); if current_address_list_ptr_ptr ^= null () then do; /*** Looking for addresses after "-from", "-to", ... */ call mlsys_utils_$parse_address_list_control_args (P_sci_ptr, argument_idx, addr (local_pcao), ADDRESS_LIST_VERSION_2, current_address_list_ptr, sdm_subsystem_info.bcc, code); if (code ^= 0) & (code ^= mlsys_et_$ca_parse_failed) then call ssu_$abort_line (P_sci_ptr, code, "Parsing control arguments."); found_invalid_address = found_invalid_address | (code = mlsys_et_$ca_parse_failed); end; if argument_idx <= n_arguments then do; /*** Either still looking for message specifiers or an argument not recognized by the mail system */ call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ /*** reply request control arguments ... */ if (argument = "-include_deleted") | (argument = "-idl") then msg_type = ALL_MESSAGES; else if (argument = "-only_deleted") | (argument = "-odl") then msg_type = ONLY_DELETED_MESSAGES; else if (argument = "-only_non_deleted") | (argument = "-ondl") then msg_type = NON_DELETED_MESSAGES; else if (argument = "-delete") | (argument = "-dl") then delete_after_processing = "1"b; else if (argument = "-no_delete") | (argument = "-ndl") then delete_after_processing = "0"b; else if (argument = "-message") | (argument = "-msg") then do; call get_next_argument ("A message specifier"); call process_arg_as_spec (); end; else if (argument = "-include_authors") | (argument = "-include_author") | (argument = "-iat") then include_authors_arg = INCLUDE_AUTHORS; else if (argument = "-no_include_authors") | (argument = "-no_include_author") | (argument = "-niat") then include_authors_arg = NO_INCLUDE_AUTHORS; else if (argument = "-include_recipients") | (argument = "-irc") then include_recipients = "1"b; else if (argument = "-no_include_recipients") | (argument = "-nirc") then include_recipients = "0"b; else if (argument = "-include_self") | (argument = "-is") then include_self, dont_issue_nis_warning = "1"b; else if (argument = "-no_include_self") | (argument = "-nis") then do; include_self = "0"b; dont_issue_nis_warning = "1"b; end; else if (argument = "-include_original") | (argument = "-io") then sdm_subsystem_info.include_original_text = "1"b; else if (argument = "-no_include_original") | (argument = "-nio") then sdm_subsystem_info.include_original_text = "0"b; else if (argument = "-refill") | (argument = "-rfi") then sdm_subsystem_info.fill_original_text = "1"b; else if (argument = "-no_refill") | (argument = "-nrfi") then sdm_subsystem_info.fill_original_text = "0"b; else if (argument = "-indent") | (argument = "-ind") | (argument = "-in") then do; call get_next_argument ("A number"); sdm_subsystem_info.original_text_indentation = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "-indent ^a", argument); if (sdm_subsystem_info.original_text_indentation < 0) | (sdm_subsystem_info.original_text_indentation > 30) then call ssu_$abort_line (P_sci_ptr, code, "Indentation must be between 0 and 30; not ""^a"".", argument); end; /*** Standard send_mail control arguments ... */ else if (argument = "-terminal_input") | (argument = "-ti") then sdm_subsystem_info.input_type = TERMINAL_INPUT; else if (argument = "-input_file") | (argument = "-if") then do; call get_next_argument ("A pathname"); sdm_subsystem_info.input_type = FILE_INPUT; input_filename_ptr = argument_ptr; input_filename_lth = argument_lth; end; /* save it for later processing */ else if argument = "-from" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.from); else if (argument = "-reply_to") | (argument = "-rpt") then current_address_list_ptr_ptr = addr (sdm_subsystem_info.reply_to); else if argument = "-to" then do; to_arg_specified = "1"b; /* ... turns off the -include_authors default */ current_address_list_ptr_ptr = addr (sdm_subsystem_info.to); end; else if argument = "-cc" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.cc); else if argument = "-bcc" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.bcc); else if (argument = "-log") | (argument = "-save") | (argument = "-sv") then do; /*** ... must recognize these arguments even before "-to", etc. */ call mlsys_utils_$parse_address_control_args (P_sci_ptr, argument_idx, addr (local_pcao), address_ptr, code); if (code ^= 0) & (code ^= mlsys_et_$ca_parse_failed) then call ssu_$abort_line (P_sci_ptr, code, "Parsing control arguments."); found_invalid_address = found_invalid_address | (code = mlsys_et_$ca_parse_failed); if address_ptr ^= null () then do; call mail_system_$add_address (sdm_subsystem_info.bcc, address_ptr, ADDRESS_LIST_VERSION_2, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Adding ^[logbox^;savebox^] address to bcc field.", (argument = "-log")); address_ptr = null (); end; argument_idx = argument_idx - 1; end; /* is incremented below */ else if (argument = "-subject") | (argument = "-sj") then do; call get_next_argument ("A string"); sdm_subsystem_info.subject_given = "1"b; sdm_subsystem_info.subject_ptr = argument_ptr; sdm_subsystem_info.subject_lth = argument_lth; end; else if (argument = "-no_subject") | (argument = "-nsj") then do; sdm_subsystem_info.subject_given = "1"b; sdm_subsystem_info.subject_lth = 0; end; else if argument = "-abort" then abort = "1"b; else if argument = "-no_abort" then abort = "0"b; else if (argument = "-acknowledge") | (argument = "-ack") then sdm_subsystem_info.acknowledge = "1"b; else if (argument = "-no_acknowledge") | (argument = "-nack") then sdm_subsystem_info.acknowledge = "0"b; else if (argument = "-brief") | (argument = "-bf") then sdm_subsystem_info.brief = "1"b; else if (argument = "-long") | (argument = "-lg") then sdm_subsystem_info.brief = "0"b; else if (argument = "-fill") | (argument = "-fi") then sdm_subsystem_info.fill_control = FILL; else if (argument = "-no_fill") | (argument = "-nfi") then sdm_subsystem_info.fill_control = NO_FILL; else if (argument = "-line_length") | (argument = "-ll") then do; call get_next_argument ("A number"); sdm_subsystem_info.fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "-line_length ""^a""", argument); if sdm_subsystem_info.fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else if (argument = "-notify") | (argument = "-nt") then sdm_subsystem_info.notify = "1"b; else if (argument = "-no_notify") | (argument = "-nnt") then sdm_subsystem_info.notify = "0"b; /*** Control arguments required by the MCR boards despite the furious objections of the author */ else if argument = "-auto_write" then sdm_subsystem_info.auto_write = "1"b; else if argument = "-no_auto_write" then sdm_subsystem_info.auto_write = "0"b; /*** Standard subsystem control arguments */ else if (argument = "-abbrev") | (argument = "-ab") then sdm_subsystem_info.abbrev, abbrev_ca_given = "1"b; else if (argument = "-no_abbrev") | (argument = "-nab") then do; sdm_subsystem_info.abbrev = "0"b; abbrev_ca_given = "1"b; end; else if (argument = "-profile") | (argument = "-pf") then do; call get_next_argument ("A pathname"); profile_pathname_given = "1"b; profile_pathname_ptr = argument_ptr; profile_pathname_lth = argument_lth; end; /* save for later processing */ else if (argument = "-debug") | (argument = "-db") then sdm_subsystem_info.debug = "1"b; else if (argument = "-no_debug") | (argument = "-ndb") then sdm_subsystem_info.debug = "0"b; else if (argument = "-prompt") | (argument = "-pmt") then do; call get_next_argument ("A string"); if argument_lth = 0 then /* same as -no_prompt */ sdm_subsystem_info.prompt_control.prompt_control = NO_PROMPT; else do; sdm_subsystem_info.prompt_control.prompt_control = USE_PROMPT_STRING; sdm_subsystem_info.prompt_string = argument; end; end; else if (argument = "-no_prompt") | (argument = "-npmt") then sdm_subsystem_info.prompt_control.prompt_control = NO_PROMPT; else if (argument = "-request") | (argument = "-rq") then do; call get_next_argument ("A string"); sdm_subsystem_info.initial_requests_ptr = argument_ptr; sdm_subsystem_info.initial_requests_lth = argument_lth; end; else if (argument = "-request_loop") | (argument = "-rql") then sdm_subsystem_info.request_loop_control = REQUEST_LOOP; else if (argument = "-no_request_loop") | (argument = "-nrql") then sdm_subsystem_info.request_loop_control = NO_REQUEST_LOOP; /*** Control arguments which are now obsolete: delete in MR11 */ else if (argument = "-all") | (argument = "-a") then msg_type = ALL_MESSAGES; else if (argument = "-message_id") | (argument = "-mid") | (argument = "-no_message_id") | (argument = "-nmid") then ; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else do; /*** Non-control argument: a message specifier */ if current_address_list_ptr_ptr ^= null () then call ssu_$abort_line (P_sci_ptr, 0, "No implicit message specifiers may follow the ""-from"", ""-reply_to"", ""-to"", ""-cc"", or ""-bcc"" control arguments" ); call process_arg_as_spec (); end; argument_idx = argument_idx + 1; /* skip past the argument we just processed */ end; end; if sdm_subsystem_info.input_type = FILE_INPUT then do; /*** Verify that the specified input file exists ... */ call expand_pathname_ (input_filename, sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-input_file ""^a""", input_filename); call initiate_file_ (sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename, R_ACCESS, input_file_ptr, (0), code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-input_file ""^a""", pathname_ (sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename)); call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); end; if profile_pathname_given then do; /*** Initiate the subsystem profile requested by the user */ call expand_pathname_$add_suffix (profile_pathname, "profile", profile_dirname, profile_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-profile ""^a""", profile_pathname); call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, sdm_subsystem_info.default_profile_ptr, (0), code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "-profile ""^a""", pathname_ (profile_dirname, profile_ename)); if ^abbrev_ca_given then /* -profile implies -abbrev unless explicit -ab/-nab given */ sdm_subsystem_info.abbrev = "1"b; abbrev_ca_given = "1"b; /* do not copy read_mail's abbreviation processing state */ end; /* Establish the remaining parameters for the send_mail invocation */ if ^abbrev_ca_given then do; /*** User did not give any abbrev control arguments: use read_mail's state of abbreviation processing */ call ssu_$get_abbrev_info (P_sci_ptr, sdm_subsystem_info.default_profile_ptr, sdm_subsystem_info.profile_ptr, abbrev_enabled); sdm_subsystem_info.abbrev = abbrev_enabled; /* attributes don't match, sigh... */ if sdm_subsystem_info.default_profile_ptr ^= null () then call add_null_refname (sdm_subsystem_info.default_profile_ptr); if (sdm_subsystem_info.profile_ptr ^= null ()) & (sdm_subsystem_info.profile_ptr ^= sdm_subsystem_info.default_profile_ptr) then call add_null_refname (sdm_subsystem_info.profile_ptr); end; /* ssu_ never terminiates same profile twice */ /* If invalid addresses were found on the request line and -abort (the default) was specified, abort the request here. Otherwise (-no_abort specified), force the user to enter send_mail's request loop; a warning to this effect will be issued later */ if found_invalid_address then /* there are indeed invalid addresses ... */ if abort then /* ... and the user doesn't want to continue */ call ssu_$abort_line (P_sci_ptr, 0); else sdm_subsystem_info.request_loop_control = REQUEST_LOOP; /* ... force the user to fix the addresses */ /* Check for inconsistencies and supply appropriate defaults where needed */ if ^sdm_subsystem_info.include_original_text & (sdm_subsystem_info.original_text_indentation >= 0) then call ssu_$abort_line (P_sci_ptr, error_table_$inconsistent, """-indent"" without ""-include_original""."); if ^sdm_subsystem_info.include_original_text & sdm_subsystem_info.fill_original_text then call ssu_$abort_line (P_sci_ptr, error_table_$inconsistent, """-refill"" without ""-include_original""."); if sdm_subsystem_info.original_text_indentation < 0 then sdm_subsystem_info.original_text_indentation = rdm_invocation.reply_options.indentation; /* indent by default value if not otherwise specified */ if include_authors_arg = DEFAULT_INCLUDE_AUTHORS then if to_arg_specified then /* ... if explicit -to given do not include the authors */ include_authors = "0"b; else include_authors = rdm_invocation.include_authors; else if include_authors_arg = NO_INCLUDE_AUTHORS then include_authors = "0"b; else /*** if include_authors_arg = INCLUDE_AUTHORS then */ include_authors = "1"b; if msg_spec_count = 0 then /* defaults to the current message (if any) */ call rdm_message_mark_mgr_$mark_current_message (rdm_invocation_ptr, msg_type); /* phx19099 RL - use of "-odl" with the current message will be caught during marking */ else call process_msg_specs (); /* mark the messages the caller asked for */ /* Build the reply message */ if ^include_self then do; /* will have to check addresses against ourselves */ call user_info_ (my_person_id); /* ... may be needed for warnings */ compare_both_user_addresses = ^ mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address, mlsys_data_$user_mail_table_address, (0)); if ^dont_issue_nis_warning then /* ... see if user explicitly sending himself a copy */ call check_if_explicit_self (); end; original_messages_n_original_messages = marked_chain.n_messages; allocate original_messages in (rdm_area) set (original_messages_ptr); original_messages.version = ORIGINAL_MESSAGES_VERSION_1; do message_idx = 1 to marked_chain.n_messages; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); original_messages.messages (message_idx).message_ptr = message_ptr; original_messages.messages (message_idx).message_idx = message_number; /* phx18564 RL - set current message to message_number and guarantee that it's not deleted */ call rdm_mailbox_interface_$set_new_current_msg (rdm_invocation_ptr, message_number, rdm_invocation.current_message); /* it's current while we're working on it */ call process_message (); call rdm_mailbox_interface_$mark_processed_and_acknowledge (rdm_invocation_ptr, message_number); end; sdm_subsystem_info.original_messages_ptr = original_messages_ptr; if ^sdm_subsystem_info.subject_given then do; /* no subject in original messages ... */ sdm_subsystem_info.subject_given = "1"b; /* ... force the reply to have no subject also */ sdm_subsystem_info.subject_lth = 0; end; /* Eliminate duplicate recipients and, if not brief, list the recipients */ call mail_system_$eliminate_duplicate_addresses (recipients_lists_array, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Eliminating duplicate recipients."); recipient_count = 0; /* just count top-level addresses */ do address_list_ptr = sdm_subsystem_info.to, sdm_subsystem_info.cc, sdm_subsystem_info.bcc; if ^is_empty_list (address_list_ptr) then recipient_count = recipient_count + address_list.n_addresses; end; if recipient_count = 0 then call ssu_$abort_line (P_sci_ptr, mlsys_et_$no_recipients); if found_invalid_address then do; /* force the user into the request loop */ sdm_subsystem_info.request_loop_control = REQUEST_LOOP; call ssu_$print_message (P_sci_ptr, 0, "Invalid addresses were detected. The send_mail request loop will be entered to permit corrections.") ; end; if ^sdm_subsystem_info.brief then /* tell user who's getting it */ call print_recipients_list (); /* Invoke send_mail */ call rdm_message_mark_mgr_$mark_original_messages (rdm_invocation_ptr); saved_current_message = rdm_invocation.current_message; clear_original_message_chain = "1"b; call sdm_subsystem_$subsystem (sdm_invocation_ptr, sdm_subsystem_info_ptr, code); clear_original_message_chain = "0"b; rdm_invocation.current_message = saved_current_message; /* in case some send_mail request changes it */ call rdm_message_mark_mgr_$clear_original_messages (rdm_invocation_ptr); if code ^= 0 then if code = emf_et_$send_mail_aborted then /* message was modified/unprocessed on exit */ if ^sdm_subsystem_info.brief & delete_after_processing then call ssu_$abort_line (P_sci_ptr, 0, "Reply not sent. Message(s) will not be deleted."); else call ssu_$abort_line (P_sci_ptr, 0); else call ssu_$abort_line (P_sci_ptr, code, "Invoking send_mail subsystem."); if delete_after_processing then /* delete messages after replying */ call rdm_mailbox_interface_$delete_messages (rdm_invocation_ptr, "0"b); call cleanup_after_reply_request (); return; %page; /* Fetches the value expected after the given control argument */ get_next_argument: procedure (p_argument_type); dcl p_argument_type character (*) parameter; if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "^a after ""^a"".", p_argument_type, argument); argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); return; end get_next_argument; %page; /* Adds the current argument to the array of message specifies for this request */ process_arg_as_spec: procedure (); if msg_spec_count >= hbound (msg_spec_array, 1) then call ssu_$abort_line (P_sci_ptr, 0, "Too many message specifiers on the request line."); /* can't ever happen */ msg_spec_count = msg_spec_count + 1; msg_spec_array (msg_spec_count) = argument_idx; return; end process_arg_as_spec; /* Processes the message specifies to produce the chain of messages to be processed by this request */ process_msg_specs: procedure (); dcl idx fixed bin; do idx = 1 to msg_spec_count; call ssu_$arg_ptr (P_sci_ptr, msg_spec_array (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, msg_type, ""b, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code); end; return; end process_msg_specs; %page; /* Cleans up after execution of the request */ cleanup_after_reply_request: procedure (); if clear_original_message_chain then do; call rdm_message_mark_mgr_$clear_original_messages (rdm_invocation_ptr); rdm_invocation.current_message = saved_current_message; end; if input_file_ptr ^= null () then call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); if profile_ptr ^= null () then call terminate_file_ (profile_ptr, 0, TERM_FILE_TERM, (0)); if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0)); if (sdm_invocation_ptr ^= null ()) | (sdm_subsystem_info_ptr ^= null ()) then call sdm_subsystem_$destroy_invocation (sdm_invocation_ptr, sdm_subsystem_info_ptr); return; end cleanup_after_reply_request; %page; /* Processes a single message: If this is the first message with a non-null subject, it's subject will be used as the subject for the reply (with "Re:" prefixed to the subject if needed). The authors and recipients of the message will be added to the reply's recipients as requested by the user */ process_message: procedure (); if ^sdm_subsystem_info.subject_given then /* add the first non-null subject we can find */ call set_reply_subject_if_ok (); warning_given_for_this_message = "0"b; /* don't give -no_include_self warning twice */ if include_authors then if is_empty_list (message.reply_to) then /* no Reply-To: use the From field which is never empty */ call add_recipients (message.from, sdm_subsystem_info.to); else call add_recipients (message.reply_to, sdm_subsystem_info.to); if include_recipients then do; if ^is_empty_list (message.to) then call add_recipients (message.to, sdm_subsystem_info.cc); if ^is_empty_list (message.cc) then call add_recipients (message.cc, sdm_subsystem_info.cc); if ^is_empty_list (message.bcc) then call add_recipients (message.bcc, sdm_subsystem_info.bcc); end; return; /* Internal to process_message: Sets the subject of the reply to this message's subject prefixed by "Re:" if this message's subject is non-null */ set_reply_subject_if_ok: procedure (); dcl reply_subject character (reply_subject_lth) unaligned based (reply_subject_ptr); dcl reply_subject_ptr pointer; dcl reply_subject_lth fixed binary (21); if length (message_subject) = 0 then return; /* no subject */ sdm_subsystem_info.subject_given = "1"b; /* only the first non-null subject is used */ if translate (substr (message_subject, 1, min (3, length (message_subject))), "Re", "rE") = "Re:" then do; reply_subject_lth = length (message_subject); allocate reply_subject in (rdm_area) set (reply_subject_ptr); reply_subject = message_subject; substr (reply_subject, 1, 3) = "Re:"; end; else do; reply_subject_lth = length (message_subject) + length ("Re: "); allocate reply_subject in (rdm_area) set (reply_subject_ptr); reply_subject = "Re: " || message_subject; end; sdm_subsystem_info.subject_ptr = reply_subject_ptr; sdm_subsystem_info.subject_lth = reply_subject_lth; return; end set_reply_subject_if_ok; %page; /* Internal to process_message: Adds the addresses in the specified header field of an original message to one of the recipient header fields (To, cc, bcc) of the reply message: Any addresses which refer to the user issuing the reply are eliminated if so requested */ add_recipients: procedure (p_original_field, p_reply_recipient_field); dcl p_original_field pointer parameter; dcl p_reply_recipient_field pointer parameter; dcl address_ptr pointer; dcl code fixed binary (35); dcl address_idx fixed binary; address_list_ptr = p_original_field; /* guarenteed not empty by our caller */ do address_idx = 1 to address_list.n_addresses; address_ptr = address_list.addresses (address_idx); call mail_system_$validate_address (address_ptr, "0"b /* don't expand mailing lists */, code); if code = 0 then do; /* address is OK ... */ if ^include_self then /* ... but we must check for self-references */ if mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address, address_ptr, (0)) then do; IGNORE_ADDRESS: /* ... and it is our own address */ if ^dont_issue_nis_warning then do; if ^warning_given_for_this_message then call ssu_$print_message (P_sci_ptr, 0, "Message #^d -- no reply sent to ^a due to ""-no_include_self"" default.", message_number, my_person_id); warning_given_for_this_message = "1"b; end; go to PROCESS_NEXT_ADDRESS; end; else if compare_both_user_addresses then if mail_system_$compare_addresses (mlsys_data_$user_mail_table_address, address_ptr, (0)) then go to IGNORE_ADDRESS; call mail_system_$add_address (p_reply_recipient_field, address_ptr, ADDRESS_LIST_VERSION_2, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Message #^d -- processing ""^[-include_authors^;-include_recipients^]"".", message_number, (addr (p_reply_recipient_field) = addr (sdm_subsystem_info.to))); end; else do; /* invalid address ... */ found_invalid_address = "1"b; /* ... force the request loop */ call mlsys_utils_$print_validate_results (P_sci_ptr, address_ptr, code); end; PROCESS_NEXT_ADDRESS: end; return; end add_recipients; end process_message; %page; /* Checks if the user has explicitly included himself as a recipient of the reply: If so, and -no_include_self is specified, the warning messages issued when excluding an implicit self reference will be suppressed */ check_if_explicit_self: procedure (); if ^is_empty_list (sdm_subsystem_info.to) then call check_single_list (sdm_subsystem_info.to); if ^is_empty_list (sdm_subsystem_info.cc) then call check_single_list (sdm_subsystem_info.cc); if ^is_empty_list (sdm_subsystem_info.bcc) then call check_single_list (sdm_subsystem_info.bcc); RETURN_FROM_CHECK_IF_EXPLICIT_SELF: return; /* Internal to check_if_explicit_self: actually performs the check */ check_single_list: procedure (p_address_list_ptr); dcl p_address_list_ptr pointer parameter; dcl address_ptr pointer; dcl address_idx fixed binary; address_list_ptr = p_address_list_ptr; do address_idx = 1 to address_list.n_addresses; address_ptr = address_list.addresses (address_idx); if mail_system_$compare_addresses (mlsys_data_$user_default_mailbox_address, address_ptr, (0)) then do; dont_issue_nis_warning = "1"b; /* found an explicit match */ go to RETURN_FROM_CHECK_IF_EXPLICIT_SELF; end; else if compare_both_user_addresses then if mail_system_$compare_addresses (mlsys_data_$user_mail_table_address, address_ptr, (0)) then do; dont_issue_nis_warning = "1"b; go to RETURN_FROM_CHECK_IF_EXPLICIT_SELF; end; end; return; end check_single_list; end check_if_explicit_self; %page; /* Print the list of recipients of the message: as many recipients as will fit on one line are printed with an indication of the total number in the list */ print_recipients_list: procedure (); dcl (recipients_list_ptr, address_ptr) pointer; dcl (n_recipients_left, address_idx) fixed binary; dcl n_recipients_left_picture picture "(8)z9"; dcl include_comma bit (1) aligned; dcl recipients_list /* the "Replying to..." message */ character (get_line_length_$switch (iox_$user_output, (0)) - line_prefix_length ()) varying; dcl address_summary /* the text for one address */ character (get_line_length_$switch (iox_$user_output, (0)) - line_prefix_length ()) varying; recipients_list_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; if recipients_list_ptr ^= null () then call mail_system_$free_address_list (recipients_list_ptr, (0)); end; do address_list_ptr = sdm_subsystem_info.to, sdm_subsystem_info.cc, sdm_subsystem_info.bcc; if is_empty_list (address_list_ptr) then /* nothing in this one: however, at least one isn't empty */ code = 0; else call mail_system_$merge_address_lists (recipients_list_ptr, address_list_ptr, "0"b, recipients_list_ptr, code); if code ^= 0 then do; CANT_GENERATE_RECIPIENTS_LIST: call ssu_$print_message (P_sci_ptr, 0, "Replying to ^d total recipient^[s^].", recipient_count, (recipient_count ^= 1)); go to RETURN_FROM_PRINT_RECIPIENTS_LIST; end; end; recipients_list = "Replying to "; /* prime the output */ n_recipients_left = recipients_list_ptr -> address_list.n_addresses - 1; /* at least the first address appears */ call mlsys_utils_$summarize_address (recipients_list_ptr -> address_list.addresses (1), "0"b, address_summary, code); if code ^= 0 then go to CANT_GENERATE_RECIPIENTS_LIST; if ^is_room_for_address () then go to CANT_GENERATE_RECIPIENTS_LIST; recipients_list = recipients_list || address_summary; include_comma = "0"b; do address_idx = 2 to recipients_list_ptr -> address_list.n_addresses; address_ptr = recipients_list_ptr -> address_list.addresses (address_idx); n_recipients_left = n_recipients_left - 1; /* insures the test will be oK */ call mlsys_utils_$summarize_address (address_ptr, "0"b, address_summary, code); if (code ^= 0) & (code ^= error_table_$smallarg) then go to CANT_GENERATE_RECIPIENTS_LIST; if code = 0 then /* got the summary */ if is_room_for_address () then do; /* ... and it will fit */ if ^include_comma & (n_recipients_left > 0) then include_comma = "1"b; if include_comma then recipients_list = recipients_list || ","; if n_recipients_left = 0 then recipients_list = recipients_list || " and "; else recipients_list = recipients_list || " "; recipients_list = recipients_list || address_summary; end; else do; /* ... but it won't fit on the line */ n_recipients_left = n_recipients_left + 1; go to FINISH_AND_PRINT_RECIPIENTS_LIST; end; else do; /* address summary is too long */ n_recipients_left = n_recipients_left + 1; go to FINISH_AND_PRINT_RECIPIENTS_LIST; end; include_comma = "1"b; /* definitely need one now */ end; FINISH_AND_PRINT_RECIPIENTS_LIST: if n_recipients_left > 0 then do; if include_comma then recipients_list = recipients_list || ","; recipients_list = recipients_list || " and "; recipients_list = recipients_list || ltrim (convert (n_recipients_left_picture, n_recipients_left)); if n_recipients_left = 1 then recipients_list = recipients_list || " other"; else recipients_list = recipients_list || " others"; end; recipients_list = recipients_list || "."; call ssu_$print_message (P_sci_ptr, 0, "^a", recipients_list); RETURN_FROM_PRINT_RECIPIENTS_LIST: if recipients_list_ptr ^= null () then call mail_system_$free_address_list (recipients_list_ptr, (0)); return; /* Internal to print_recipients_list: determines the length of the prefix printed by ssu_$print_message */ line_prefix_length: procedure () returns (fixed binary); return (length (ssu_$get_subsystem_and_request_name (P_sci_ptr)) + length (": ")); end line_prefix_length; /* Internal to print_recipients_list: determines if this address will fit in the remainder of the line */ is_room_for_address: procedure () returns (bit (1) aligned); if n_recipients_left > 0 then return ((length (recipients_list) + length (address_summary) + length (", , and NNN others.")) <= maxlength (recipients_list)); else return ((length (recipients_list) + length (address_summary) + length (", and .")) <= maxlength (recipients_list)); end is_room_for_address; end print_recipients_list; %page; /* Adds a null reference name to the supplied profile: ssu_ will terminate a null refname when the send_mail invocation is destroyed but read_mail will still try to reference the profile; adding an extra null refname here makes everything work properly */ add_null_refname: procedure (p_profile_ptr); dcl p_profile_ptr pointer parameter; dcl new_profile_ptr pointer; dcl profile_dirname character (168); dcl profile_ename character (32); call hcs_$fs_get_path_name (p_profile_ptr, profile_dirname, (0), profile_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Copying state of read_mail abbrev processing."); call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, new_profile_ptr, (0), code); if p_profile_ptr ^= new_profile_ptr then call ssu_$abort_line (P_sci_ptr, code, "Copying state of read_mail abbrev processing."); return; end add_null_refname; /* Determines if the supplied address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* nothing there at all */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include sdm_subsystem_info; %page; %include send_mail_options; %page; %include sdm_original_messages; %page; %include mlsys_data; %page; %include mlsys_parse_ca_options; %page; %include mlsys_message; %page; %include mlsys_address_list; %page; %include access_mode_values; %page; %include terminate_file; end rdm_reply_request_;  rdm_request_tables_.alm 11/05/86 1552.0r w 11/04/86 1038.6 82197 " *********************************************************** " * * " * 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-26,Herbst), approve(86-03-26,MCR7367), " audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): " Added switch_on and switch_off requests. Added seen, unseen, new, and " (first last next previous)_(seen unseen) requests. " 2) change(86-04-02,Herbst), approve(86-04-02,MCR7367), " audit(86-04-28,Margolin), install(86-05-22,MR12.0-1059): " Moved requests from rdm_message_mark_mgr_ to rdm_msg_requests_. " END HISTORY COMMENTS " Request definitions for the Multics read_mail subsystem " Created: 3 July 1978 by W. Olin Sibert -- converted from sdm_request_table_ " Modified: 28 April 1980 by G. Palter to call new_ssu_ entries for version 4.1 subsystem utilities " Modified: 10 May 1980 by W. Olin Sibert to use ssu_v1_macros, and to call ssu_requests_ " for subsystem standard requests " Modified: 14 May 1980 by W. Olin Sibert to rearrange requests and add 'list_help' " Modified: 17 December 1981 by G. Palter to rearrange requests, use new definition of '?', " and add 'list_requests' " Modified: 16 February 1982 by G. Palter to use new macros and add 'exec_com', 'answer', " 'abbrev', and 'if' " Modified: 25 February 1982 by G. Palter to add 'subsystem_name' and 'subsystem_version' " Modified: 28 February 1982 by G. Palter for dont_summarize and dont_list flags " Modified: 21 September 1982 by G. Palter to rename to rdm_request_tables_, add the " debug_requests table, and delete the standard subsystem request from the tables " Modified: 13 September 1983 by G. Palter to eliminate the 'ssu_debug' request as debug " mode now enables ssu_ debugging " Modified: October 1983 by G. Palter to reflect the splitting of rdm_transfer_requests_ " into rdm_file_requests_ and rdm_mbx_requests_ " Modified: October 1983 by B. Margolin to add the requests for the forward sub-request " loop. include ssu_request_macros name rdm_request_tables_ " " Standard read_mail requests begin_table standard_requests request ., rdm_misc_requests_$self_identify, (), (Print current status.) request quit, rdm_misc_requests_$quit_request, (q), (Leave read_mail.) request print, rdm_msg_requests_$print_request, (pr,p), (Print the specified messages.) request print_header, rdm_msg_requests_$print_header_request, (prhe), (Print the headers of the specified messages.) request list, rdm_msg_requests_$list_request, (ls), (List the specified messages.), flags.allow_both request delete, rdm_msg_requests_$delete_request, (dl,d), (Delete the specified messages.) request retrieve, rdm_msg_requests_$retrieve_request, (rt), (Retrieve the specified messages after deletion.) request reply, rdm_reply_request_$reply_request, (rp), (Reply to the specified messages.) request write, rdm_file_requests_$write_request, (w), (Write a single message into a segment, unformatted.) request log, rdm_mbx_requests_$log_request, (), (Save the specified messages into the default log mailbox.) request save, rdm_mbx_requests_$save_request, (sv), (Save the specified messages into a specified save mailbox.) request forward, rdm_forward_request_$forward_request, (fwd,for), (Forward the specified message to other users.) request copy, rdm_mbx_requests_$copy_request, (cp), (Copy the specified messages into another mailbox.) request append, rdm_file_requests_$append_request, (app), (Append messages to the end of an existing file.) request preface, rdm_file_requests_$preface_request, (prf), (Preface the messages at the front of an existing file.) request mailbox, rdm_msg_requests_$mailbox_request, (mbx), (Return the pathname of the mailbox being read.), flags.allow_both request first, rdm_msg_requests_$first_request, (f), (Return the number of the first message.), flags.allow_both request last, rdm_msg_requests_$last_request, (l), (Return the number of the last message.), flags.allow_both request current, rdm_msg_requests_$current_request, (c), (Return the number of the current message.), flags.allow_both request previous, rdm_msg_requests_$previous_request, (), (Return the number of the previous message.), flags.allow_both request next, rdm_msg_requests_$next_request, (), (Return the number of the next message.), flags.allow_both request all, rdm_msg_requests_$all_request, (), (Return the numbers of all the messages.), flags.allow_both request seen, rdm_msg_requests_$seen_request, (), (Return the numbers of all seen messages.), flags.allow_both+flags.dont_summarize request unseen, rdm_msg_requests_$unseen_request, (), (Return the numbers of all unseen messages.), flags.allow_both+flags.dont_summarize request new, rdm_msg_requests_$new_request, (), (Return the numbers of all new messages.), flags.allow_both+flags.dont_summarize request first_seen, rdm_msg_requests_$first_seen_request, (fs), (Return the number of the first seen message.), flags.allow_both+flags.dont_summarize request first_unseen, rdm_msg_requests_$first_unseen_request, (fu), (Return the number of the first unseen message.), flags.allow_both+flags.dont_summarize request last_seen, rdm_msg_requests_$last_seen_request, (), (Return the number of the last seen message.), flags.allow_both+flags.dont_summarize request last_unseen, rdm_msg_requests_$last_unseen_request, (lu), (Return the number of the last unseen message.), flags.allow_both+flags.dont_summarize request next_seen, rdm_msg_requests_$next_seen_request, (ns), (Return the number of the next seen message.), flags.allow_both+flags.dont_summarize request next_unseen, rdm_msg_requests_$next_unseen_request, (nu), (Return the number of the next unseen message.), flags.allow_both+flags.dont_summarize request previous_seen, rdm_msg_requests_$previous_seen_request, (ps), (Return the number of the previous seen message.), flags.allow_both+flags.dont_summarize request previous_unseen, rdm_msg_requests_$previous_unseen_request, (pu), (Return the number of the previous unseen message.), flags.allow_both+flags.dont_summarize request apply, rdm_apply_request_$apply_request, (ap), (Apply a Multics command line to the specified messages.) request switch_on, rdm_msg_requests_$switch_on_request, (swn), (Turn on the specified per-message switch, eg. the seen switch.) request switch_off, rdm_msg_requests_$switch_off_request, (swf), (Turn off the specified per-message switch, eg. the seen switch.) request debug_mode, rdm_debug_requests_$debug_mode, (), (Enable/disable read_mail debugging facilities.), flags.allow_command+flags.dont_summarize+flags.dont_list end_table standard_requests " " Requests used for debugging read_mail begin_table debug_requests request probe, rdm_debug_requests_$probe, (pb), (Invokes the probe debugger with all available data structures.), flags.allow_command+flags.dont_summarize+flags.dont_list end_table debug_requests " " Requests used by the sub-request loop of the read_mail forward request begin_table forward_requests request quit, rdm_fwd_misc_requests_$quit_request, (q), (Exit the forwarding sub-request loop without sending the forwarded message.) request print, rdm_fwd_text_requests_$print_request, (pr,p), (Print the comment text.) request send, rdm_fwd_misc_requests_$send_request, (), (Send the forwarded message.) request qedx, rdm_fwd_text_requests_$qedx_request, (qx), (Edit the comment text.) request fill, rdm_fwd_text_requests_$fill_request, (fi), (Reformat text of the comment to fit in given width.) request apply, rdm_fwd_text_requests_$apply_request, (ap), (Apply a Multics command line to the comment text.) request debug_mode, rdm_fwd_debug_requests_$debug_mode, (), (Enable/disable forwarding debugging facilities.), flags.allow_command+flags.dont_summarize+flags.dont_list request probe, rdm_fwd_debug_requests_$probe, (pb), (Invokes the probe debugger with all available data structures.), flags.allow_command+flags.dont_summarize+flags.dont_list request print_original, rdm_msg_requests_$print_request, (pro), (Prints the message(s) being forwarded.) end_table forward_requests end  rdm_search_utils_.pl1 12/09/83 1325.7r w 12/09/83 1255.9 99837 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ /* read_mail Utilities releated to searching the printed representation of various parts of a message for a given character string /* Created: September 1983 by G. Palter */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen,^indcomtxt */ rdm_search_utils_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_rdm_invocation_ptr pointer parameter; dcl P_message_number fixed binary parameter; /* identifies the message */ dcl P_regexp_ptr pointer parameter; /* search_message_wwith_regexp: -> the regular expression */ dcl P_regexp_lth fixed binary (21) parameter; /* search_message_wwith_regexp: length of said expression */ dcl P_fieldname character (*) varying parameter; /* prepare_*_field_for_search: the name of the field being prepared for use in error messages */ dcl P_field_value pointer parameter; /* prepare_*_field_for_search: -> the value of the field */ dcl P_representation_ptr pointer parameter; /* prepare_*_field_for_search: set -> the printed representation of the field to be used for the search */ dcl P_representation_lth fixed binary (21) parameter; /* prepare_*_field_for_search: set to the length of said printed representation */ /**** format:indcomtxt */ /* Local copies of parameters */ dcl message_number fixed binary; dcl the_regexp character (regexp_lth) unaligned based (regexp_ptr); dcl regexp_ptr pointer; dcl regexp_lth fixed binary (21); /* Remaining declarations */ dcl field_formatter entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)) variable; dcl 1 local_fmo aligned like format_message_options; dcl message_ptr pointer; dcl previous_buffer_used fixed binary (21); dcl code fixed binary (35); dcl MINIMUM_BUFFER_SIZE fixed binary (21) static options (constant) initial (32768); dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (error_table_$nomatch, error_table_$smallarg, mlsys_et_$message_too_large, mlsys_et_$no_message_canonical_form) fixed binary (35) external; /* format: on */ dcl mail_system_$read_message_canonical_form entry (pointer, fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_address_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_message_canonical_form entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_references_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl search_file_$silent entry (pointer, fixed binary (21), fixed binary (21), pointer, fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (21), fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl (addcharno, addr, null) builtin; %page; /* Search the canonical form of a message for the given qedx regular expression: The canonical form of a message is the text used by the mail system when it stores the message in a mailbox. In order to avoid the expense of constructing this text for each search, this entrypoint first attempts to obtain the canonical form from ring-2; if successfull, this entrypoint then saves the text for the remainder of the read_mail invocation. If ring-2 does not provide a canonical form, this entrypoint will construct it once in its own set of temporary segments and then save it for the life of the invocation */ search_message_with_regexp: entry (P_rdm_invocation_ptr, P_message_number, P_regexp_ptr, P_regexp_lth) returns (bit (1) aligned); rdm_invocation_ptr = P_rdm_invocation_ptr; regexp_ptr = P_regexp_ptr; regexp_lth = P_regexp_lth; message_number = P_message_number; if (message_number < 1) | (message_number > message_list.n_messages) then call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "There is no message ^d.", message_number); if message_list.messages (message_number).message_idx = 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, 0, "Message ^d has already been permanently deleted from the mailbox.", message_number); if message_list.messages (message_number).search_text_ptr = null () then do; /* First time searching this message: check if ring-2 already has the canonical form of this message */ call mail_system_$read_message_canonical_form (rdm_invocation.mailbox_ptr, message_list.messages (message_number).message_idx, message_list.messages (message_number).search_text_ptr, message_list.messages (message_number).search_text_lth, code); if (code ^= 0) & (code ^= mlsys_et_$no_message_canonical_form) then call ssu_$abort_line (rdm_invocation.sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); end; if message_list.messages (message_number).search_text_ptr = null () then do; /* First time and ring-2 doesn't have the canonical form of this message: construct it once for this invocation */ call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, message_ptr, code); if code ^= 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = -1; /* don't bother with making it pretty */ local_fmo.envelope_formatting_mode, /* use the format most familiar to users */ local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE; local_fmo.include_body = "1"b; if (rdm_invocation.last_search_buffer.buffer_used + MINIMUM_BUFFER_SIZE) > (4 * sys_info$max_seg_size) then call get_fresh_buffer_segment (); /* go right to the virgin buffer */ RETRY_FORMAT_MESSAGE_CALL: previous_buffer_used = rdm_invocation.last_search_buffer.buffer_used; call mlsys_utils_$format_message_canonical_form (message_ptr, addr (local_fmo), rdm_invocation.last_search_buffer.buffer_ptr, 4 * sys_info$max_seg_size, rdm_invocation.last_search_buffer.buffer_used, code); if (code ^= 0) & (code ^= error_table_$smallarg) then call ssu_$abort_line (rdm_invocation.sci_ptr, code, "Attempting to prepare message #^d for searching.", message_number); if code = error_table_$smallarg then /* buffer wasn't large enough */ if previous_buffer_used = 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, mlsys_et_$message_too_large, "Attempting to prepare message #^d for searching.", message_number); else do; call get_fresh_buffer_segment (); /* try again with an entire segment as the buffer */ go to RETRY_FORMAT_MESSAGE_CALL; end; message_list.messages (message_number).search_text_ptr = addcharno (rdm_invocation.last_search_buffer.buffer_ptr, previous_buffer_used); message_list.messages (message_number).search_text_lth = rdm_invocation.last_search_buffer.buffer_used - previous_buffer_used; end; /* Now search for given regular expression */ call search_file_$silent (regexp_ptr, 1, regexp_lth, message_list.messages (message_number).search_text_ptr, 1, message_list.messages (message_number).search_text_lth, (0), (0), code); if (code ^= 0) & (code ^= error_table_$nomatch) then call ssu_$abort_line (rdm_invocation.sci_ptr, code, "Attempting to search message ^d for ""/^a/"".", message_number, the_regexp); return ((code = 0)); %page; /* Prepares a copy of the printed representation of various types of message fields in the temporary segments managed by this module in order to save other modules which must search said fields the expsense of having to format the fields multiple times. See rdm_msg_requests_ for an example of how to use these entrypoints */ prepare_address_list_field_for_search: /* ... address list fields (From, To, etc.) */ entry (P_rdm_invocation_ptr, P_message_number, P_fieldname, P_field_value, P_representation_ptr, P_representation_lth); field_formatter = mlsys_utils_$format_address_list_field; go to PREPARE_FIELD_FOR_SEARCH; prepare_message_references_field_for_search: /* ... list of references fields (ie: In-Reply-To) */ entry (P_rdm_invocation_ptr, P_message_number, P_fieldname, P_field_value, P_representation_ptr, P_representation_lth); field_formatter = mlsys_utils_$format_references_list_field; go to PREPARE_FIELD_FOR_SEARCH; /* Prepare a message field for one or more subsequent searches */ PREPARE_FIELD_FOR_SEARCH: rdm_invocation_ptr = P_rdm_invocation_ptr; message_number = P_message_number; if (rdm_invocation.last_search_buffer.buffer_used + MINIMUM_BUFFER_SIZE) > (4 * sys_info$max_seg_size) then call get_fresh_buffer_segment (); /* go right to the virgin buffer */ RETRY_FORMAT_FIELD_CALL: previous_buffer_used = rdm_invocation.last_search_buffer.buffer_used; call field_formatter ("", P_field_value, -1, rdm_invocation.last_search_buffer.buffer_ptr, 4 * sys_info$max_seg_size, rdm_invocation.last_search_buffer.buffer_used, code); if (code ^= 0) & (code ^= error_table_$smallarg) then call ssu_$abort_line (rdm_invocation.sci_ptr, code, "Attempting to prepare the ^a field of message #^d for searching.", P_fieldname, message_number); if code = error_table_$smallarg then /* buffer wasn't large enough */ if previous_buffer_used = 0 then call ssu_$abort_line (rdm_invocation.sci_ptr, mlsys_et_$message_too_large, "Attempting to prepare the ^a field of message #^d for searching.", P_fieldname, message_number); else do; call get_fresh_buffer_segment (); /* try again with an entire segment as the buffer */ go to RETRY_FORMAT_FIELD_CALL; end; P_representation_ptr = addcharno (rdm_invocation.last_search_buffer.buffer_ptr, previous_buffer_used); P_representation_lth = rdm_invocation.last_search_buffer.buffer_used - previous_buffer_used; return; %page; /* Obtains a fresh temporary segment */ get_fresh_buffer_segment: procedure (); call ssu_$get_temp_segment (rdm_invocation.sci_ptr, "search-buffer", rdm_invocation.last_search_buffer.buffer_ptr); rdm_invocation.last_search_buffer.buffer_used = 0; return; end get_fresh_buffer_segment; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include mlsys_format_options; end rdm_search_utils_;  rdm_set_request_tables_.pl1 10/27/83 1616.3rew 10/27/83 1442.2 21141 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* Sets the request table list used by the read_mail subsystem */ /* Created: 17 September 1982 by G. Palter */ /* Modified: 13 September 1983 by G. Palter as part of the conversion of read_mail to the new mail system interface */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ rdm_set_request_tables_: procedure (P_rdm_invocation_ptr, P_code); /* Parameters */ dcl P_rdm_invocation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; /* read_mail request tables */ dcl 1 rdm_request_tables aligned, 2 header like request_tables_list.header, 2 tables (3) like request_tables_list.tables; /* up to 3 possible tables (see below) */ /* Remaining declarations */ dcl table_idx fixed binary; /* format: off */ dcl (rdm_request_tables_$standard_requests, rdm_request_tables_$debug_requests, ssu_request_tables_$standard_requests) bit (36) aligned external; /* format: on */ dcl ssu_$set_request_tables entry (pointer, pointer, fixed binary (35)); dcl addr builtin; %page; /* rdm_set_request_tables_: entry (P_rdm_invocation_ptr, P_code); */ rdm_invocation_ptr = P_rdm_invocation_ptr; rdm_request_tables.version = REQUEST_TABLES_LIST_VERSION_1; table_idx = 1; /* always include standard read_mail requests */ rdm_request_tables.tables (1).table_ptr = addr (rdm_request_tables_$standard_requests); if rdm_invocation.debug_mode then do; /* include debugging requests if needed */ table_idx = table_idx + 1; rdm_request_tables.tables (table_idx).table_ptr = addr (rdm_request_tables_$debug_requests); end; table_idx = table_idx + 1; /* standard subsystem requests are always last */ rdm_request_tables.tables (table_idx).table_ptr = addr (ssu_request_tables_$standard_requests); rdm_request_tables.n_tables = table_idx; call ssu_$set_request_tables (rdm_invocation.sci_ptr, addr (rdm_request_tables), P_code); return; %page; %include rdm_invocation; %page; %include ssu_request_tables_list; end rdm_set_request_tables_;  read_mail.pl1 04/24/92 1657.0r w 04/24/92 1627.8 289908 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(91-12-04,Huen), approve(91-12-04,MCR8239), audit(92-02-13,Zimmerman), install(92-04-24,MR12.5-1013): Fix mail_362 - check for new messages after every request line. END HISTORY COMMENTS */ /* format: off */ /* The Multics read_mail command: an interactive subsystem to peruse the messages in a mailbox */ /* Written: 3 July 1978 W. Olin Sibert */ /* Modified: 21 June 1979 by G. Palter to fix ACL bug in creation of user's mailbox */ /* Modified: 25 December 1979 by W. Olin Sibert to cause invalid control argument combinations to be diagnosed earlier (read_mail bug #133), and to allow specification of more reply options on the command line (read_mail bug #132) */ /* Modified: 11 April 1980 by G. Palter to correct mail_system bug #0178 -- print_mail and read_mail behave poorly when invoked as active functions */ /* Modified: 25 April 1980 by G. Palter to implement suggestion #084 -- provide abbrev expansion of request lines; the -abbrev, -no_abbrev, and -profile control arguments are added */ /* Modified: 28 April 1980 by G. Palter to call v1_ssu_ entries for version 4.1 subsystems */ /* Modified: 5 May 1980 by W. Olin Sibert to convert to new ssu_ interface */ /* Modified: 31 May 1980 by G. Palter to fix bug #0291 -- read_mail does not recognize the "-no_list" and "-no_print" control arguments */ /* Modified: 5 June 1980 by G. Palter to fix bug #0241 -- "read_mail quit" leaves undestroyed invocations of read_mail lying around */ /* Modified: 10 June 1980 by G. Palter to implement suggestion #0320 -- read_mail should have a program interrupt handler which is active during the execution of "canned" request lines (eg: from "read_mail -print") which causes read_mail to enter the request loop */ /* Modified: 27 November 1980 by G. Palter to fix bug #0342 -- specifying a mailbox on the read_mail or print_mail command line without using a control argument causes all previous mailbox specifications to be ignored; an error message about multiple mailbox specifications should be issued instead. EG: read_mail -user Palter.PDO Sibert.PDO will read the mail in Sibert.PDO's mailbox */ /* Modified: 27 January 1981 by G. Palter to fix bug #0354 -- both read_mail and send_mail mis-declare ssu_$set_prompt: for read_mail, the declaration used works; for send_mail, use of -no_prompt can cause severe problems */ /* Modified: 30 January 1981 by G. Palter to fix an unreported bug where specifying the "sv.mbx" suffix would fail when using the "-save" control argument */ /* Modified: 16 February 1982 by G. Palter for new calling sequences of ssu_$create_invocation and ssu_$set_abbrev_info */ /* Modified: September 1982 by G. Palter to split off print_mail, to support new send_mail fill control, to add -debug/-no_debug, and to set proper exec_com suffix and search list */ /* Modified: 7 November 1982 by G. Palter to make rdm_info.reply_options.include_self a three-way switch */ /* Modified: September 1983 by G. Palter to convert to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ read_mail: rdm: procedure () options (variable); dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl profile_pathname character (profile_pathname_lth) unaligned based (profile_pathname_ptr); dcl profile_dirname character (168); dcl profile_ename character (32); dcl (profile_ptr, profile_pathname_ptr) pointer; dcl profile_pathname_lth fixed binary (21); dcl (enable_abbrev, abbrev_ca_given, profile_pathname_given) bit (1) aligned; dcl subsystem_area area aligned based (subsystem_area_ptr); dcl subsystem_area_ptr pointer; dcl 1 local_pcao aligned like parse_ca_options; dcl 1 local_ai aligned like area_info; dcl (sci_ptr, rdm_sci_ptr) pointer; dcl have_mailbox bit (1) aligned; /* ON => have seen a mailbox pathname on the command line */ dcl mailbox_dirname character (168); dcl mailbox_ename character (32); dcl mail bit (1) aligned; /* ON => include ordinary messages from the mailbox */ dcl interactive_messages bit (1) aligned; /* ON => include interactive messages from the mailbox */ dcl display_message_count bit (1) aligned; /* ON => tell the user how many messages are in the mailbox */ dcl totals_only bit (1) aligned; /* ON => exit immediately after printing the message count */ dcl enter_request_loop_if_no_messages bit (1) aligned; /* ON => enter the request loop even if mailbox is empty */ dcl list_messages bit (1) aligned; /* ON => summarize the messages before the request loop */ dcl print_messages bit (1) aligned; /* ON => print the messages before the request loop */ dcl quit_after_request_line bit (1) aligned; /* ON => exit immediately after -list/-print/-request done */ dcl request_line_given bit (1) aligned; /* ON => user has supplied a request line to execute */ dcl request_line_ptr pointer; dcl request_line_lth fixed binary (21); dcl prompt_control bit (2) aligned; /* controls prompting */ dcl prompt_string character (64) varying; dcl code fixed binary (35); dcl READ_MAIL character (32) static options (constant) initial ("read_mail"); dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (error_table_$bad_conversion, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args, mlsys_et_$mailbox_exists, ssu_et_$program_interrupt, ssu_et_$request_line_aborted, ssu_et_$subsystem_aborted) fixed binary (35) external; /* format: on */ dcl active_fnc_err_ entry options (variable); dcl com_err_ entry () options (variable); dcl cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl ioa_ entry () options (variable); dcl mail_system_$close_mailbox entry (pointer, pointer, fixed binary (35)); dcl mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35)); dcl mlsys_utils_$create_default_mailbox entry (fixed binary (35)); dcl mlsys_utils_$parse_mailbox_control_args entry (pointer, fixed binary, pointer, character (*), character (*), fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl rdm_mailbox_interface_$expunge_messages entry (pointer, bit (1) aligned); dcl rdm_mailbox_interface_$open_mailbox entry (pointer, character (*), character (*), pointer, fixed binary (35)); dcl rdm_mailbox_interface_$read_new_messages entry (pointer, bit (1) aligned, fixed binary (35)); dcl rdm_set_request_tables_ entry (pointer, fixed binary (35)); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$create_invocation entry (character (*), character (*), pointer, pointer, character (*), pointer, fixed binary (35)); dcl ssu_$destroy_invocation entry (pointer); dcl ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl ssu_$execute_string entry (pointer, character (*), fixed binary (35)); dcl ssu_$get_area entry (pointer, pointer, character (*), pointer); dcl ssu_$listen entry (pointer, pointer, fixed binary (35)); dcl ssu_$print_blast entry (pointer, pointer, fixed binary, character (*) varying, fixed binary (35)); dcl ssu_$print_message entry () options (variable); dcl ssu_$record_usage entry (pointer, pointer, fixed binary (35)); dcl ssu_$set_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned); dcl ssu_$set_debug_mode entry (pointer, bit (1) aligned); dcl ssu_$set_ec_search_list entry (pointer, character (32)); dcl ssu_$set_ec_suffix entry (pointer, character (32)); dcl ssu_$set_info_ptr entry (pointer, pointer); dcl ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35)); dcl ssu_$set_prompt entry (pointer, character (64) varying); dcl ssu_$set_prompt_mode entry (pointer, bit (*)); dcl ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35)); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl cleanup condition; dcl (addr, codeptr, index, null, string, substr, translate, unspec) builtin; %page; /* read_mail: rdm: entry options (variable); */ /* Initialize the read_mail invocation */ sci_ptr, /* for cleanup handler */ rdm_invocation_ptr, rdm_sci_ptr, profile_ptr = null (); on condition (cleanup) call release_data_structures (); call ssu_$standalone_invocation (sci_ptr, READ_MAIL, "argument-parse", cu_$arg_list_ptr (), abort_read_mail_command, code); if code ^= 0 then do; /* please forgive the following, but ... */ if cu_$af_return_arg (0, (null ()), (0)) = 0 then call active_fnc_err_ (code, READ_MAIL, "Can not establish standalone subsystem invocation."); else call com_err_ (code, READ_MAIL, "Can not establish standalone subsystem invocation."); return; end; call ssu_$arg_count (sci_ptr, n_arguments); /* aborts if not a command */ call ssu_$create_invocation (READ_MAIL, (rdm_data_$version), null (), null (), rdm_data_$info_directory, rdm_sci_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Creating the subsystem invocation."); unspec (local_ai) = ""b; local_ai.version = area_info_version_1; local_ai.zero_on_alloc, local_ai.extend = "1"b; call ssu_$get_area (rdm_sci_ptr, addr (local_ai), "", subsystem_area_ptr); allocate rdm_invocation in (subsystem_area) set (rdm_invocation_ptr); rdm_invocation.type = RDM_INVOCATION; rdm_invocation.sci_ptr = rdm_sci_ptr; rdm_sci_ptr = null (); /* don't try to destroy the invocation twice */ rdm_invocation.area_ptr = subsystem_area_ptr; /* use the above area for all allocations */ rdm_invocation.mailbox_ptr, /* haven't opened the mailbox yet */ rdm_invocation.message_list_ptr, rdm_invocation.message_chains = null (); rdm_invocation.mailbox_name = ""; rdm_invocation.current_message = 0; /* the mailbox isn't open: there can't be a current message */ rdm_invocation.last_search_buffer.buffer_ptr = null (); rdm_invocation.last_search_buffer.buffer_used = 4 * sys_info$max_seg_size; call ssu_$set_info_ptr (rdm_invocation.sci_ptr, rdm_invocation_ptr); /* Initialize default options: reading the user's profile will go here someday */ begin; /* avoids problems with duplicate named constants */ dcl 1 local_oo aligned like open_options; %include mlsys_open_options; have_mailbox = "0"b; /* haven't seen a mailbox yet */ mail = "1"b; /* assume ordinary mail ... */ interactive_messages = "0"b; /* ... but not interactive messages by default */ local_oo.version = OPEN_OPTIONS_VERSION_2; local_oo.sender_selection_mode = ACCESSIBLE_MESSAGES; /* read all messages (if possible) */ local_oo.message_reading_level = READ_KEYS; /* will fetch messages one at a time (faster startup) */ display_message_count = "1"b; /* state how many messages before anything else */ totals_only = "0"b; /* do not print just the message count */ enter_request_loop_if_no_messages = "0"b; /* -no_request_loop */ list_messages, print_messages, request_line_given, quit_after_request_line = "0"b; /* nothing special before the request loop */ prompt_control = DEFAULT_PROMPT; /* use standard prompt */ prompt_string = ""; enable_abbrev, abbrev_ca_given, profile_pathname_given = "0"b; /* abbreviation processing isn't enabled by default */ rdm_invocation.acknowledge = "1"b; /* -acknowledge, -long, -no_debug ... */ rdm_invocation.brief, rdm_invocation.debug_mode = "0"b; rdm_invocation.print_options.formatting_mode = DEFAULT_FORMATTING_MODE; /* default for the print request is: -header */ rdm_invocation.reply_options.line_length = 72; rdm_invocation.reply_options.indentation = 4;/* indent the original (if included) to make it stand out */ rdm_invocation.reply_options.include_authors = "1"b; rdm_invocation.reply_options.include_recipients = "0"b; rdm_invocation.reply_options.include_self = DEFAULT_INCLUDE_SELF; rdm_invocation.reply_options.fill_control = DEFAULT_FILL; /* Process arguments */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode, /* logbox/savebox must already exist */ local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; string (local_pcao.flags) = ""b; local_pcao.abort_on_errors = "1"b; /* any errors are immediately fatal */ local_pcao.validate_addresses = "1"b; /* insure that any mailbox specified actually exists */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-mail") | (argument = "-ml") then mail = "1"b; else if (argument = "-no_mail") | (argument = "-nml") then mail = "0"b; else if (argument = "-interactive_messages") | (argument = "-im") then interactive_messages = "1"b; else if (argument = "-no_interactive_messages") | (argument = "-nim") then interactive_messages = "0"b; else if (argument = "-accessible") | (argument = "-acc") then local_oo.sender_selection_mode = ACCESSIBLE_MESSAGES; else if (argument = "-all") | (argument = "-a") then local_oo.sender_selection_mode = ALL_MESSAGES; else if argument = "-own" then local_oo.sender_selection_mode = OWN_MESSAGES; else if argument = "-not_own" then local_oo.sender_selection_mode = NOT_OWN_MESSAGES; else if (argument = "-count") | (argument = "-ct") then display_message_count = "1"b; else if (argument = "-no_count") | (argument = "-nct") then display_message_count = "0"b; else if (argument = "-totals") | (argument = "-total") | (argument = "-tt") then totals_only = "1"b; else if (argument = "-force") | (argument = "-fc") | (argument = "-request_loop") | (argument = "-rql") then enter_request_loop_if_no_messages = "1"b; else if (argument = "-no_force") | (argument = "-nfc") | (argument = "-no_request_loop") | (argument = "-nrql") then enter_request_loop_if_no_messages = "0"b; else if (argument = "-list") | (argument = "-ls") then list_messages = "1"b; else if (argument = "-no_list") | (argument = "-nls") then list_messages = "0"b; else if (argument = "-print") | (argument = "-pr") then print_messages = "1"b; else if (argument = "-no_print") | (argument = "-npr") then print_messages = "0"b; else if (argument = "-request") | (argument = "-rq") then do; call get_next_argument ("A string"); request_line_given = "1"b; request_line_ptr = argument_ptr; request_line_lth = argument_lth; end; else if argument = "-quit" then quit_after_request_line = "1"b; else if (argument = "-prompt") | (argument = "-pmt") then do; call get_next_argument ("A string"); if argument = "" then /* equivalent to -no_prompt */ prompt_control = NO_PROMPT; else do; /* a real prompt string */ prompt_control = USE_PROMPT_STRING; prompt_string = argument; end; end; else if (argument = "-no_prompt") | (argument = "-npmt") then prompt_control = NO_PROMPT; else if (argument = "-abbrev") | (argument = "-ab") then enable_abbrev, abbrev_ca_given = "1"b; else if (argument = "-no_abbrev") | (argument = "-nab") then do; enable_abbrev = "0"b; abbrev_ca_given = "1"b; end; else if (argument = "-profile") | (argument = "-pf") then do; call get_next_argument ("A pathname"); profile_pathname_given = "1"b;/* we'll check it out later */ profile_pathname_ptr = argument_ptr; profile_pathname_lth = argument_lth; end; else if (argument = "-acknowledge") | (argument = "-ack") then rdm_invocation.acknowledge = "1"b; else if (argument = "-no_acknowledge") | (argument = "-nack") then rdm_invocation.acknowledge = "0"b; else if (argument = "-brief") | (argument = "-bf") then rdm_invocation.brief = "1"b; else if (argument = "-long") | (argument = "-lg") then rdm_invocation.brief = "0"b; else if (argument = "-debug") | (argument = "-db") then rdm_invocation.debug_mode = "1"b; else if (argument = "-no_debug") | (argument = "-ndb") then rdm_invocation.debug_mode = "0"b; else if (argument = "-long_header") | (argument = "-lghe") then rdm_invocation.print_options.formatting_mode = LONG_FORMATTING_MODE; else if (argument = "-header") | (argument = "-he") then rdm_invocation.print_options.formatting_mode = DEFAULT_FORMATTING_MODE; else if (argument = "-brief_header") | (argument = "-bfhe") then rdm_invocation.print_options.formatting_mode = BRIEF_FORMATTING_MODE; else if (argument = "-no_header") | (argument = "-nhe") then rdm_invocation.print_options.formatting_mode = NONE_FORMATTING_MODE; else if (argument = "-line_length") | (argument = "-ll") then do; call get_next_argument ("A number"); rdm_invocation.reply_options.line_length = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion, "-line_length ""^a""", argument); if rdm_invocation.reply_options.line_length < 31 then call ssu_$abort_subsystem (sci_ptr, 0, "Reply line length must be greater than 30; not ""^a"".", argument); end; else if (argument = "-indent") | (argument = "-ind") | (argument = "-in") then do; call get_next_argument ("A number"); rdm_invocation.reply_options.indentation = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion, "-indent ""^a""", argument); if (rdm_invocation.reply_options.indentation < 0) | (rdm_invocation.reply_options.indentation > 30) then call ssu_$abort_subsystem (sci_ptr, 0, "Reply indentation must be between 0 and 30; not ""^a"".", argument); end; else if (argument = "-include_original") | (argument = "-io") then rdm_invocation.reply_options.include_original = "1"b; else if (argument = "-no_include_original") | (argument = "-nio") then rdm_invocation.reply_options.include_original = "0"b; else if (argument = "-include_authors") | (argument = "-iat") then rdm_invocation.reply_options.include_authors = "1"b; else if (argument = "-no_include_authors") | (argument = "-niat") then rdm_invocation.reply_options.include_authors = "0"b; else if (argument = "-include_recipients") | (argument = "-irc") then rdm_invocation.reply_options.include_recipients = "1"b; else if (argument = "-no_include_recipients") | (argument = "-nirc") then rdm_invocation.reply_options.include_recipients = "0"b; else if (argument = "-include_self") | (argument = "-is") then rdm_invocation.reply_options.include_self = INCLUDE_SELF; else if (argument = "-no_include_self") | (argument = "-nis") then rdm_invocation.reply_options.include_self = NO_INCLUDE_SELF; else if (argument = "-fill") | (argument = "-fi") then rdm_invocation.reply_options.fill_control = FILL; else if (argument = "-no_fill") | (argument = "-nfi") then rdm_invocation.reply_options.fill_control = NO_FILL; else go to TRY_ARGUMENT_AS_MAILBOX_PATHNAME; /* unknown control argument: maybe a mailbox speciifer? */ else do; TRY_ARGUMENT_AS_MAILBOX_PATHNAME: /* not a control argument: myst be a mailbox specifier */ call mlsys_utils_$parse_mailbox_control_args (sci_ptr, argument_idx, addr (local_pcao), mailbox_dirname, mailbox_ename, (0)); /* ... above entrypoint aborts us if anything's wrong */ argument_idx = argument_idx - 1; /* ... do loop will increment it */ if have_mailbox then /* ... this one's OK and we already have one (sigh) */ call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, "Only one mailbox may be specified."); have_mailbox = "1"b; /* ... now we've got the mailbox to be read */ end; end; if ^mail & ^interactive_messages then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-no_mail"" and ""-no_interactive_messages"""); if totals_only & (enter_request_loop_if_no_messages | list_messages | print_messages | request_line_given | quit_after_request_line) then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-totals"" and^[ ""-request_loop""^]^[ ""-list""^]^[ ""-print""^]^[ ""-request""^]^[ ""-quit""^].", enter_request_loop_if_no_messages, list_messages, print_messages, request_line_given, quit_after_request_line); if quit_after_request_line & ^(list_messages | print_messages | request_line_given) then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "One of ""-list"", ""-print"", or ""-request"" must be specified with ""-quit""."); /* If no mailbox was given on the command line, use the user's default mailbox which is created if necessary */ if ^have_mailbox then do; call mail_system_$get_address_pathname (mlsys_data_$user_default_mailbox_address, mailbox_dirname, mailbox_ename, ((32)" "), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Getting the pathname of your mailbox."); call mlsys_utils_$create_default_mailbox (code); if code = 0 then /* just created it ... */ call ssu_$print_message (sci_ptr, 0, "Created ^a.", pathname_ (mailbox_dirname, mailbox_ename)); else if code ^= mlsys_et_$mailbox_exists then call ssu_$abort_subsystem (sci_ptr, code, "Attempting to create your default mailbox. ^a", pathname_ (mailbox_dirname, mailbox_ename)); end; /* Complete the read_mail environment */ if profile_pathname_given then do; /* an explicit profile was requested */ call expand_pathname_$add_suffix (profile_pathname, "profile", profile_dirname, profile_ename, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-profile ""^a""", profile_pathname); call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, profile_ptr, (0), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-profile ""^a""", pathname_ (profile_dirname, profile_ename)); if ^abbrev_ca_given then /* -profile implies -abbrev unless explicit -ab/-nab given */ enable_abbrev = "1"b; end; call ssu_$set_abbrev_info (rdm_invocation.sci_ptr, profile_ptr, null (), enable_abbrev); profile_ptr = null (); /* we'll let ssu_ terminate it for us */ call ssu_$set_debug_mode (rdm_invocation.sci_ptr, (rdm_invocation.debug_mode)); call rdm_set_request_tables_ (rdm_invocation_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Unable to setup request tables."); if prompt_control = USE_PROMPT_STRING then call ssu_$set_prompt (rdm_invocation.sci_ptr, prompt_string); else if prompt_control = NO_PROMPT then call ssu_$set_prompt_mode (rdm_invocation.sci_ptr, DONT_PROMPT); call ssu_$set_ec_suffix (rdm_invocation.sci_ptr, rdm_data_$ec_suffix); call ssu_$set_ec_search_list (rdm_invocation.sci_ptr, rdm_data_$ec_search_list); /* Open the mailbox, check the salvaged flag, and report the message count */ if mail & interactive_messages then /* want all types of messages */ local_oo.message_selection_mode = ALL_MESSAGES; else if mail then /* only want ordinary mail messages */ local_oo.message_selection_mode = ORDINARY_MESSAGES; else local_oo.message_selection_mode = INTERACTIVE_MESSAGES; /* interactive messages only */ call rdm_mailbox_interface_$open_mailbox (rdm_invocation_ptr, mailbox_dirname, mailbox_ename, addr (local_oo), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Attempting to open ^a.", pathname_ (mailbox_dirname, mailbox_ename)); mailbox_ptr = rdm_invocation.mailbox_ptr; /* will need to access this now */ if mailbox.mailbox_type = USER_DEFAULT_MAILBOX then rdm_invocation.mailbox_name = "your mailbox"; else if mailbox.mailbox_type = USER_LOGBOX then rdm_invocation.mailbox_name = "your logbox"; else rdm_invocation.mailbox_name = pathname_ (mailbox_dirname, mailbox_ename); if mailbox.salvaged then /* something was probably lost ... */ if rdm_invocation.brief then call ssu_$print_message (sci_ptr, 0, "Mailbox has been salvaged."); else call ssu_$print_message (sci_ptr, 0, "Warning: ^a^a has been salvaged since it was last read.^/Some messages may have been lost.", translate (substr (rdm_invocation.mailbox_name, 1, 1), "Y", "y"), substr (rdm_invocation.mailbox_name, 2)); if display_message_count then /* user wants to know how much is there */ if mailbox.n_messages = 0 then if rdm_invocation.brief then call ioa_ ("No mail."); else call ioa_ ("^[You have no mail^s^;^[You have no messages^;There is no mail^]^]^[ in ^a^].", (mailbox.mailbox_type = USER_DEFAULT_MAILBOX), (mailbox.sender_selection_mode = OWN_MESSAGES), (mailbox.mailbox_type ^= USER_DEFAULT_MAILBOX), rdm_invocation.mailbox_name); else if mailbox.n_messages = 1 then if rdm_invocation.brief then call ioa_ ("One message."); else call ioa_ ( "^[You have one message^s^;^[You have one message^;There is one message^]^]^[ in ^a^].", (mailbox.mailbox_type = USER_DEFAULT_MAILBOX), (mailbox.sender_selection_mode = OWN_MESSAGES), (mailbox.mailbox_type ^= USER_DEFAULT_MAILBOX), rdm_invocation.mailbox_name); else /*** if mailbox.n_messages > 1 then */ do; if rdm_invocation.brief then call ioa_ ("^d messages.", mailbox.n_messages); else call ioa_ ("^[You have^s^;^[You have^;There are^]^] ^d messages^[ in ^a^].", (mailbox.mailbox_type = USER_DEFAULT_MAILBOX), (mailbox.sender_selection_mode = OWN_MESSAGES), mailbox.n_messages, (mailbox.mailbox_type ^= USER_DEFAULT_MAILBOX), rdm_invocation.mailbox_name); end; end; if totals_only | /* only wanted the message count */ ((mailbox.n_messages = 0) & ^enter_request_loop_if_no_messages) then go to RETURN_FROM_READ_MAIL; /* Mailbox is open and there are messages present: this invocation is, therefore, going to do some real work */ if rdm_data_$first_invocation then call ssu_$print_blast (rdm_invocation.sci_ptr, codeptr (read_mail), 3, rdm_data_$special_message, (0)); else call ssu_$record_usage (rdm_invocation.sci_ptr, codeptr (read_mail), (0)); rdm_data_$first_invocation = "0"b; /* only issue the blast once per process */ /* Summarize the messages if requested via "-list" */ if list_messages then do; call ssu_$execute_string (rdm_invocation.sci_ptr, "list all", code); if code = ssu_et_$program_interrupt then go to ENTER_REQUEST_LOOP; else if code = ssu_et_$request_line_aborted then go to EXIT_READ_MAIL_OR_ENTER_REQUEST_LOOP; end; /* Print the messages if requested via "-print" */ if print_messages then do; call ssu_$execute_string (rdm_invocation.sci_ptr, "print all", code); if code = ssu_et_$program_interrupt then go to ENTER_REQUEST_LOOP; else if code = ssu_et_$request_line_aborted then go to EXIT_READ_MAIL_OR_ENTER_REQUEST_LOOP; end; /* Execute any user-supplied request line and, if "-quit" was not specified, enter the request loop */ if request_line_given then do; /* user had some explicit requests */ call ssu_$execute_line (rdm_invocation.sci_ptr, request_line_ptr, request_line_lth, code); if code = ssu_et_$program_interrupt then go to ENTER_REQUEST_LOOP; else if code = ssu_et_$subsystem_aborted then go to RETURN_FROM_READ_MAIL; end; EXIT_READ_MAIL_OR_ENTER_REQUEST_LOOP: /* transfer point if any of the above runs into trouble ... */ if quit_after_request_line then /* user asked us to stop even if there were errors ... */ call rdm_mailbox_interface_$expunge_messages (rdm_invocation_ptr, ("0"b)); else do; /* user wants to get into the request loop ... */ ENTER_REQUEST_LOOP: call ssu_$set_procedure (rdm_invocation.sci_ptr, "post_request_line", post_request_line, code); call ssu_$listen (rdm_invocation.sci_ptr, null (), (0)); end; /* Cleanup */ RETURN_FROM_READ_MAIL: call release_data_structures (); return; %page; post_request_line: procedure (); call rdm_mailbox_interface_$read_new_messages (rdm_invocation_ptr, "1"b, (0)); return; end post_request_line; /* Release any data structures created herein */ release_data_structures: procedure (); dcl 1 local_co aligned like close_options; if rdm_invocation_ptr ^= null () then do; /* destroy the read_mail invocation proper */ if rdm_invocation.mailbox_ptr ^= null () then do; local_co.version = CLOSE_OPTIONS_VERSION_2; string (local_co.flags) = ""b; /* ... sets perform_deletions off */ call mail_system_$close_mailbox (rdm_invocation.mailbox_ptr, addr (local_co), (0)); end; if rdm_invocation.sci_ptr ^= null () then /* ... destroying the subsystem releases the area */ call ssu_$destroy_invocation (rdm_invocation.sci_ptr); end; if profile_ptr ^= null () then call terminate_file_ (profile_ptr, 0, TERM_FILE_TERM, (0)); if rdm_sci_ptr ^= null () then call ssu_$destroy_invocation (rdm_sci_ptr); if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end release_data_structures; /* Invoked by ssu_$abort_line and ssu_$abort_subsystem to terminate execution of read_mail */ abort_read_mail_command: procedure (); go to RETURN_FROM_READ_MAIL; end abort_read_mail_command; %page; /* Fetches the next argument for control arguments which require values */ get_next_argument: procedure (p_string); dcl p_string character (*) parameter; if argument_idx = n_arguments then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "^a after ""^a"".", p_string, argument); argument_idx = argument_idx + 1; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); return; end get_next_argument; %page; %include rdm_data; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include mlsys_data; %page; %include mlsys_mailbox; %page; %include mlsys_close_options; %page; %include mlsys_parse_ca_options; %page; %include mlsys_format_options; %page; %include area_info; %page; %include access_mode_values; %page; %include terminate_file; %page; %include ssu_prompt_modes; %page; %include send_mail_options; end read_mail;  sdm_data_.cds 07/26/88 1057.8rew 07/26/88 1013.4 98145 /* *********************************************************** * * * 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-04-14,Blair), approve(88-04-14,MCR7842), audit(88-06-29,Lippard), install(88-07-26,MR12.2-1069): Increment the version number to reflect the changes for SCP6349, add search path capability to the mail system. END HISTORY COMMENTS */ /* format: off */ /* Constant and static data used by the send_mail subsystem */ /* Created: 14 March 1978 by G. Palter */ /* Modified: 20 June 1978 by G. Palter to add info_directory */ /* Converted: 4 July 1978 by W. Olin Sibert to be rdm_data_ instead */ /* Converted: 28 December 1978 by G. Palter back to sdm_data_ */ /* Modified: 15 January 1979 by G. Palter to add no_abort option */ /* Modified: 19 March 1979 by G. Palter to make -no_message_id the default */ /* Modified: 29 December 1979 by W. Olin Sibert to add max_lock_wait_retries */ /* Modified: 25 April 1980 by G. Palter to add -abbrev and -profile options */ /* Modified: 16 February 1982 by G. Palter to add default_profile_ptr option */ /* Modified: 17 September 1982 by G. Palter to add ec_suffix and ec_search_list and to reflect new fill, prompt, and request loop control structure */ /* Recoded: August 1983 by G. Palter to use new argument processing technology for EXL/installed decision, to make the subsystem version a single character string, to support version 6 of the send_mail_options structure, and to add static data (first use/default From field) */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_data_: procedure () options (variable); dcl 1 sdm_constants aligned, 2 version character (32) varying, 2 info_directory character (168) unaligned, 2 special_message character (256) varying, 2 ec_suffix character (32) unaligned, 2 ec_search_list character (32) unaligned, 2 default_options like send_mail_options aligned; dcl 1 sdm_static aligned, 2 first_invocation bit (1) aligned, 2 default_from_field pointer; dcl 1 cds_data aligned like cds_args; /* arguments to create_data_segment_ subr */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl subsystem_type fixed binary; /* unbundled/exl/development */ dcl subsystem_version character (32) varying; dcl subsystem_info_directory character (168); dcl special_message character (256) varying; dcl special_message_given bit (1) aligned; dcl code fixed binary (35); dcl SDM_DATA_ character (32) static options (constant) initial ("sdm_data_"); dcl DEFAULT_SUBSYSTEM_VERSION character (28) varying static options (constant) initial ("8.0g"); dcl DEFAULT_SPECIAL_MESSAGE character (256) varying static options (constant) initial (""); dcl UNBUNDLED_SUBSYSTEM fixed binary static options (constant) initial (1); dcl UNBUNDLED_INFO_DIRECTORY character (168) static options (constant) initial (">doc>subsystem>mail_system>send_mail"); dcl EXL_SUBSYSTEM fixed binary static options (constant) initial (2); dcl EXL_INFO_DIRECTORY character (168) static options (constant) initial (">exl>mail_system_dir>info>send_mail"); dcl DEVELOPMENT_SUBSYSTEM fixed binary static options (constant) initial (3); dcl DEVELOPMENT_INFO_DIRECTORY character (168) static options (constant) initial (">udd>Multics>Palter>work>mail_system>info>send_mail"); /* format: off */ dcl (error_table_$bad_arg, error_table_$badopt, error_table_$bigarg) fixed binary (35) external; /* format: on */ dcl cu_$arg_count entry (fixed binary, fixed binary (35)); dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (pointer, fixed binary (35)); dcl (addr, currentsize, index, maxlength, null, string) builtin; %page; /* Determine which type (unbundled/EXL/development) and version of the subsystem is being created */ call cu_$arg_count (n_arguments, code); if code ^= 0 then do; /* not a command */ call com_err_ (code, SDM_DATA_); return; end; subsystem_type = UNBUNDLED_SUBSYSTEM; subsystem_version = DEFAULT_SUBSYSTEM_VERSION; special_message_given = "0"b; /* default depends on the subsystem version */ do argument_idx = 1 to n_arguments; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, SDM_DATA_, "Fetching argument #^d.", argument_idx); return; end; if index (argument, "-") = 1 then /* a control argument ... */ if (argument = "-unbundled") | (argument = "-unb") then subsystem_type = UNBUNDLED_SUBSYSTEM; else if (argument = "-experimental") | (argument = "-exl") then subsystem_type = EXL_SUBSYSTEM; else if (argument = "-development") | (argument = "-dev") then subsystem_type = DEVELOPMENT_SUBSYSTEM; else if argument = "-version" then do; /* specific value for the subsystem version */ if argument_idx = n_arguments then do; call com_err_ (code, SDM_DATA_, "Version string following ""^a"".", argument); return; end; argument_idx = argument_idx + 1; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, SDM_DATA_, "Fetching argument #^d.", argument_idx); return; end; if argument_lth > maxlength (DEFAULT_SUBSYSTEM_VERSION) then do; call com_err_ (error_table_$bigarg, SDM_DATA_, "Maximum length for the version string is ^d characters. ""^a""", maxlength (DEFAULT_SUBSYSTEM_VERSION), argument); return; end; subsystem_version = argument; end; else if (argument = "-message") | (argument = "-msg") then do; if argument_idx = n_arguments then do; call com_err_ (code, SDM_DATA_, "Special message text following ""^a"".", argument); return; end; argument_idx = argument_idx + 1; call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code); if code ^= 0 then do; call com_err_ (code, SDM_DATA_, "Fetching argument #^d.", argument_idx); return; end; if argument_lth > maxlength (special_message) then do; call com_err_ (error_table_$bigarg, SDM_DATA_, "Maximum length for the special message is ^d characters. ""^a""", maxlength (special_message), argument); return; end; special_message = argument; special_message_given = "1"b; end; else if (argument = "-no_message") | (argument = "-nmsg") then do; special_message = ""; /* developer wants no message for this version */ special_message_given = "1"b; end; else do; call com_err_ (error_table_$badopt, SDM_DATA_, """^a""", argument); return; end; else do; call com_err_ (error_table_$bad_arg, SDM_DATA_, """^a""", argument); return; end; end; /* Supply appropriate default values for the special message and subsystem info directory based on the type and version */ if ^special_message_given then /* defaults to builtin message only if builtin version */ if subsystem_version = DEFAULT_SUBSYSTEM_VERSION then special_message = DEFAULT_SPECIAL_MESSAGE; else special_message = ""; /* ... any other version must have the message supplied */ if subsystem_type = UNBUNDLED_SUBSYSTEM then subsystem_info_directory = UNBUNDLED_INFO_DIRECTORY; else if subsystem_type = EXL_SUBSYSTEM then do; subsystem_version = subsystem_version || " EXL"; subsystem_info_directory = EXL_INFO_DIRECTORY; end; else /*** if subsystem_type = DEVELOPMENT_SUBSYSTEM then */ do; subsystem_version = subsystem_version || " dev"; subsystem_info_directory = DEVELOPMENT_INFO_DIRECTORY; end; /* Define values for the constant data used by the subsystem */ sdm_constants.version = subsystem_version; sdm_constants.info_directory = subsystem_info_directory; sdm_constants.special_message = special_message; sdm_constants.ec_suffix = "sdmec"; /* use non-default exec_com suffix and search list */ sdm_constants.ec_search_list = "mail_system"; sdm_constants.default_options.version = SEND_MAIL_OPTIONS_VERSION_6; sdm_constants.fill_width = 72; sdm_constants.prompt_string = ""; string (sdm_constants.prompt_control.flags) = ""b; sdm_constants.prompt_control.prompt_control = DEFAULT_PROMPT; sdm_constants.default_profile_ptr = null (); /* default to use same profile as command level (if any) */ sdm_constants.profile_ptr = null (); sdm_constants.original_text_indentation = 4; string (sdm_constants.original_text_control.flags) = ""b; sdm_constants.indent_original_text = "1"b; /* indent the original text by default if it's included */ string (sdm_constants.default_options.flags) = ""b; sdm_constants.notify = "1"b; sdm_constants.debug = (subsystem_type = DEVELOPMENT_SUBSYSTEM); sdm_constants.fill_control = DEFAULT_FILL; sdm_constants.request_loop_control = DEFAULT_REQUEST_LOOP; /* above code leaves acknowledge, brief, abbrev, and auto_write off */ /* Define initial values for the static data used by the subsystem */ sdm_static.first_invocation = "1"b; /* force the initialization code to be run */ sdm_static.default_from_field = null (); /* value to be displayed as From field when it's empty */ /* Set up arguments for call to create_data_segment_ */ cds_data.sections (1).p = addr (sdm_constants); cds_data.sections (1).len = currentsize (sdm_constants); cds_data.sections (1).struct_name = "sdm_constants"; cds_data.sections (2).p = addr (sdm_static); cds_data.sections (2).len = currentsize (sdm_static); cds_data.sections (2).struct_name = "sdm_static"; cds_data.seg_name = SDM_DATA_; cds_data.num_exclude_names = 0; cds_data.exclude_array_ptr = null (); string (cds_data.switches) = ""b; cds_data.switches.have_text, cds_data.switches.have_static = "1"b; cds_data.switches.separate_static = "1"b; /* Call create_data_segment_ */ call create_data_segment_ (addr (cds_data), code); if code ^= 0 then call com_err_ (code, SDM_DATA_); return; %page; %include send_mail_options; %page; %include cds_args; end sdm_data_;  sdm_debug_requests_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 30438 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* Debugging requests for the send_mail subsystem */ /* Created: October 1982 by G. Palter */ /* Modified: 5 September 1983 by G. Palter as part of the conversion to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_debug_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); put file (sdm_debug_) data; /* forces a full symbol table ... */ return; /* ... but not really an entrypoint */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; dcl sci_ptr pointer; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl new_debug_mode bit (1) aligned; dcl code fixed binary (35); dcl sdm_debug_ file stream internal; dcl error_table_$bad_arg fixed binary (35) external; dcl error_table_$badopt fixed binary (35) external; dcl sdm_set_request_tables_ entry (pointer, fixed binary (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$set_debug_mode entry (pointer, bit (1) aligned); dcl probe entry () options (variable); dcl index builtin; %page; /* The "debug_mode" request: enables/disables send_mail debugging facilities */ debug_mode: entry (P_sci_ptr, P_sdm_invocation_ptr); sci_ptr = P_sci_ptr; sdm_invocation_ptr = P_sdm_invocation_ptr; new_debug_mode = "1"b; /* defaults to turn on debug_mode */ call ssu_$arg_count (sci_ptr, n_arguments); do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if argument = "-on" then new_debug_mode = "1"b; else if argument = "-off" then new_debug_mode = "0"b; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "This request only accepts control arguments. ""^a""", argument); end; sdm_invocation.debug_mode = new_debug_mode; call ssu_$set_debug_mode (sci_ptr, (sdm_invocation.debug_mode)); /* keep ssu_ in step */ call sdm_set_request_tables_ (sdm_invocation_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting subsystem request tables."); return; %page; /* The "probe" request: invokes the probe symbolic debugger in a stack frame with all relavent data structure available */ probe: entry (P_sci_ptr, P_sdm_invocation_ptr); sci_ptr = P_sci_ptr; sdm_invocation_ptr = P_sdm_invocation_ptr; call ssu_$arg_count (sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (sci_ptr, 0, "No arguments may be supplied."); call probe (); return; %page; %include sdm_invocation; %page; %include sdm_original_messages; %page; %include mlsys_message; %page; %include mlsys_address_list; end sdm_debug_requests_;  sdm_file_requests_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 135459 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* The send_mail write, append, and preface requests */ /* Created: 12 January 1979 by G. Palter */ /* Modified: 15 January 1979 by G. Palter to not cause faults when there is no header */ /* Modified: 16 March 1979 by G. Palter to not write the message if there is some text in it */ /* Modified: 2 June 1980 by G. Palter to fix bug #0304 -- the "write", "append", and "preface" requests should validate the name of the segment. For example, they should reject the name "x." */ /* Modified: September 1983 by G. Palter as part of the conversion to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_file_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); return; /* not an entrypoint */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; /* Local copies of parameters */ dcl sci_ptr pointer; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl message_buffer character (4 * sys_info$max_seg_size) unaligned based (message_buffer_ptr); dcl message_text character (message_text_lth) unaligned based (message_buffer_ptr); dcl message_buffer_ptr pointer; dcl message_text_lth fixed binary (21); dcl 1 local_fmo aligned like format_message_options; dcl file_dirname character (168); dcl file_ename character (32); dcl file_ptr pointer; dcl file_uid bit (36) aligned; dcl file_creation_mode fixed binary; dcl file_insertion_mode fixed binary; dcl have_filename bit (1) aligned; dcl code fixed binary (35); dcl sys_info$max_seg_size fixed binary (19) external; /* format: off */ dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$noarg, error_table_$nostars, error_table_$too_many_args,mlsys_et_$empty_message, mlsys_et_$message_too_large) fixed binary (35) external; /* format: on */ dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl emf_writing_util_$close entry (pointer, bit (36) aligned, fixed binary (35)); dcl emf_writing_util_$open entry (pointer, character (*), character (*), fixed binary, pointer, bit (36) aligned, fixed binary (35)); dcl emf_writing_util_$write entry (pointer, bit (36) aligned, character (*), fixed binary, fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl ioa_$general_rs entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned); dcl mlsys_utils_$format_address_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_address_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_date_time_field entry (character (*) varying, fixed binary (71), bit (1) aligned, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_message entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_request_name entry (pointer) returns (character (32)); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl cleanup condition; dcl (addr, index, length, max, min, null, substr) builtin; %page; /* The "write" request: adds the printed representation of the message to the end of the specified file which is created if necessary without asking the user's permission */ write_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request (); if n_arguments = 0 then call ssu_$abort_line (sci_ptr, 0, "Usage: write path {-control_args}"); on condition (cleanup) call cleanup_request (); have_filename = "0"b; file_creation_mode = SILENTLY_CREATE_FILE; file_insertion_mode = APPEND_FILE; /* default is "-extend" */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument ... */ if (argument = "-truncate") | (argument = "-tc") then file_insertion_mode = TRUNCATE_FILE; else if argument = "-extend" then file_insertion_mode = APPEND_FILE; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else if have_filename then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one pathname may be specified."); else do; have_filename = "1"b; call expand_pathname_$add_suffix (argument, "mail", file_dirname, file_ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", argument); call check_star_name_$entry (file_ename, code); if (code ^= 0) then /* validate syntax of the entryname ... */ if (code = 1) | (code = 2) then /* ... and reject starnames */ call ssu_$abort_line (sci_ptr, error_table_$nostars, "^a", pathname_ (file_dirname, file_ename)); else call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (file_dirname, file_ename)); end; end; if ^have_filename then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Pathname of output file."); call process_message (); /* do it */ call cleanup_request (); return; %page; /* The "append" request: adds the printed representation of the message to the end of the specified file. The user is asked for permission to create the file if it doesn't exist */ append_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request (); file_insertion_mode = APPEND_FILE; /* ... at the end */ go to APPEND_PREFACE_COMMON; /* The "preface" request: adds the printed representation of the message to the beginning of the specified file. The user is asked for permission to create the file if it doesn't exist */ preface_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request (); file_insertion_mode = PREFACE_FILE; /* ... at the beginning */ /* Process the append/preface request */ APPEND_PREFACE_COMMON: file_creation_mode = QUERY_TO_CREATE_FILE; if n_arguments ^= 1 then /* print an appropriate error message */ if n_arguments = 0 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path", ssu_$get_request_name (sci_ptr)); else call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Only one pathname may be specified."); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); if index (argument, "-") = 1 then call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); call expand_pathname_$add_suffix (argument, "mail", file_dirname, file_ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", argument); call check_star_name_$entry (file_ename, code); if (code ^= 0) then /* validate syntax of the entryname ... */ if (code = 1) | (code = 2) then /* ... and reject starnames */ call ssu_$abort_line (sci_ptr, error_table_$nostars, "^a", pathname_ (file_dirname, file_ename)); else call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (file_dirname, file_ename)); call process_message (); /* do it */ call cleanup_request (); return; %page; /* Performs initialization common to all requests */ setup_request: procedure (); sci_ptr = P_sci_ptr; call ssu_$arg_count (sci_ptr, n_arguments); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; file_ptr, message_buffer_ptr = null (); /* for cleanup handler */ return; end setup_request; /* Closes the file opened by this request and releases the message buffer */ cleanup_request: procedure (); if message_buffer_ptr ^= null () then call ssu_$release_temp_segment (sci_ptr, message_buffer_ptr); if file_ptr ^= null () then call emf_writing_util_$close (file_ptr, file_uid, (0)); return; end cleanup_request; %page; /* Actually performs most of the work of the above requests */ process_message: procedure (); if is_empty_message () then /* no sense in writing something without text */ call ssu_$abort_line (sci_ptr, mlsys_et_$empty_message); /* Open the file for writing */ call emf_writing_util_$open (sci_ptr, file_dirname, file_ename, file_creation_mode, file_ptr, file_uid, code); if code ^= 0 then /* couldn't open thje file ... */ if code = error_table_$action_not_performed then call ssu_$abort_line (sci_ptr, 0); /* ... and user answered "no" to the query to create it */ else call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (file_dirname, file_ename)); /* Create the printed representation of the message using the default formatting mode */ local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = min (max (sdm_invocation.fill_width, 31), 72); local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE; local_fmo.include_body = "1"b; call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "message_text", message_buffer_ptr); message_text_lth = 0; /* nothing in the buffer yet */ call add_to_buffer (" #1^[ (^d line^[s^] in body)^]:", (message.body.total_lines ^= -1), message.body.total_lines, (message.body.total_lines ^= 1)); if sdm_invocation.acknowledge then do; /* acknowledgements always come to us (for now) */ call mlsys_utils_$format_address_field (ACKNOWLEDGE_TO_FIELDNAME, sdm_data_$default_from_field -> address_list.addresses (1), local_fmo.line_length, message_buffer_ptr, length (message_buffer), message_text_lth, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing the message to be written to ^a.", pathname_ (file_dirname, file_ename)); call add_to_buffer (""); end; call mlsys_utils_$format_date_time_field (DATE_TIME_CREATED_FIELDNAME, sdm_invocation.date_time_body_modified, "1"b, local_fmo.line_length, message_buffer_ptr, length (message_buffer), message_text_lth, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing the message to be written to ^a.", pathname_ (file_dirname, file_ename)); call add_to_buffer (""); if is_empty_list (message.from) then do; /* no From field present: display the default */ call mlsys_utils_$format_address_list_field (FROM_FIELDNAME, sdm_data_$default_from_field, local_fmo.line_length, message_buffer_ptr, length (message_buffer), message_text_lth, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing the message to be written to ^a.", pathname_ (file_dirname, file_ename)); call add_to_buffer (""); end; call mlsys_utils_$format_message (message_ptr, addr (local_fmo), message_buffer_ptr, length (message_buffer), message_text_lth, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing the message to be written to ^a.", pathname_ (file_dirname, file_ename)); call add_to_buffer (" ---(1)---^2/^|"); /* Write the message into the file */ call emf_writing_util_$write (file_ptr, file_uid, message_text, file_insertion_mode, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (file_dirname, file_ename)); sdm_invocation.message_state = PROCESSED_MESSAGE; /* OK to quit without query now */ return; /* Internal to process_message: formats the given text and adds it to the message buffer */ add_to_buffer: procedure () options (variable); dcl internal_buffer character (256); /* always called with relatively short messages */ dcl internal_buffer_used fixed binary (21); call ioa_$general_rs (cu_$arg_list_ptr (), 1, 2, internal_buffer, internal_buffer_used, "0"b, "1"b); begin; dcl rest_of_message_buffer character (length (message_buffer) - message_text_lth) unaligned defined (message_buffer) position (message_text_lth + 1); if internal_buffer_used > length (rest_of_message_buffer) then call ssu_$abort_line (sci_ptr, mlsys_et_$message_too_large, "Preparing the message to be written to ^a.", pathname_ (file_dirname, file_ename)); substr (rest_of_message_buffer, 1, internal_buffer_used) = substr (internal_buffer, 1, internal_buffer_used); end; message_text_lth = message_text_lth + internal_buffer_used; return; end add_to_buffer; end process_message; %page; /* Determines if the given address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* if there's no data at all, it's empty */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; /* Determines if the message is empty */ is_empty_message: procedure () returns (bit (1) aligned); dcl idx fixed binary; do idx = 1 to message.n_body_sections; message_body_section_ptr = addr (message.body_sections (idx)); if message_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION then if message_preformatted_body_section.text_lth > 0 then return ("0"b); /* any non-zero length section => the message isn't empty */ else ; else /*** if message_body_section.section_type = MESSAGE_BIT_STRING_BODY_SECTION then */ if message_bit_string_body_section.bit_string_lth > 0 then return ("0"b); end; /* any non-zero length section => the message isn't empty */ /*** Control arrives here iff all sections in the body are empty */ return ("1"b); end is_empty_message; %page; %include sdm_invocation; %page; %include sdm_data; %page; %include send_mail_options; %page; %include emf_writing_modes; %page; %include mlsys_format_options; %page; %include mlsys_message; %page; %include mlsys_address_list; %page; %include mlsys_field_names; end sdm_file_requests_;  sdm_header_requests_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 356004 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* The send_mail from, reply_to, to, cc, bcc, subject, message_id, and remove requests */ /* Created: January 1979 by G. Palter */ /* Modified: 15 January 1979 by G. Palter to fix bug in adding to From field */ /* Modified: 27 January 1979 by G. Palter to accept -log and -save in the cc and remove requests */ /* Modified: 16 March 1979 by G. Palter to always abort the remove request if any errors are detected */ /* Modified: 25 December 1979 by W. Olin Sibert to update for new emf_info */ /* Modified: September 1983 by G. Palter as part of the conversion to the new mail system interface -- the in_reply_to request was converted into an original request and moved to sdm_original_requests_ and the bcc request was added */ /* Modified: April 1984 by G. Palter to fix the following mail system errors: #0433 -- the send_mail command and all send_mail and read_mail requests which accept multiple addresses as arguments do not properly parse "-log -at HOST" #0438 -- the primitives which allow a user to replace the address list portions of a message (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's copy of the address list read-only. Instead, they should copy the user's list to allow the user to continue to modify the list if desired for later additional use */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_header_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); return; /* not an entrypoint */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; /* Local copies of parameters */ dcl sci_ptr pointer; /* Remaining declarations */ dcl active_request bit (1) aligned; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl next_argument character (next_argument_lth) unaligned based (next_argument_ptr); dcl (argument_ptr, next_argument_ptr) pointer; dcl (argument_lth, next_argument_lth) fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl return_value character (return_value_max_lth) varying based (return_value_ptr); dcl return_value_ptr pointer; dcl return_value_max_lth fixed binary (21); dcl new_subject character (new_subject_lth) unaligned based (new_subject_ptr); dcl new_subject_ptr pointer; dcl (new_subject_lth, new_subject_used) fixed binary (21); dcl current_address_list_ptr pointer based (current_address_list_ptr_ptr); dcl current_address_list_ptr_ptr pointer; dcl 1 local_pcao aligned like parse_ca_options; dcl 1 lists aligned, /* lists of addresses to be deleted */ 2 recipients pointer, /* ... equivalent to the To, cc, and bcc fields */ 2 from pointer, 2 reply_to pointer, 2 to pointer, 2 cc pointer, 2 bcc pointer; dcl 1 all aligned, /* ON => remove all addresses from the specified field */ 2 recipients bit (1) aligned, /* ... equivalent to the To, cc, and bcc fields */ 2 from bit (1) aligned, 2 reply_to bit (1) aligned, 2 to bit (1) aligned, 2 cc bit (1) aligned, 2 bcc bit (1) aligned; dcl remove_subject bit (1) aligned; /* ON => flush the message subject */ dcl remove_in_reply_to bit (1) aligned; /* ON => flush the list of reply references */ dcl fieldname character (32) varying; /* name of the address list field being updated */ dcl address_list_field_value pointer; /* -> address list field which is to be updated */ dcl replace_field entry (pointer, pointer, fixed binary (35)) variable; dcl abort bit (1) aligned; /* ON => do not add any addresses if some are invalid */ dcl found_invalid_address bit (1) aligned; /* ON => at least one address on the request line is bad */ dcl new_addresses_ptr pointer; /* -> list of addresses to add to the field */ dcl savebox_addresses_ptr pointer; /* -> list of saveboxes to add to the bcc field */ dcl errors_detected bit (1) aligned; /* ON => abort request line containing this remove request */ dcl (new_address_list_field_value, new_to_field_value, new_cc_field_value, new_bcc_field_value, the_address) pointer; dcl (replace_to_field, replace_cc_field, replace_bcc_field, address_deleted) bit (1) aligned; dcl (address_idx, idx) fixed binary; dcl code fixed binary (35); dcl STACK_EXTENSION fixed binary (18) static options (constant) initial (128); dcl iox_$error_output pointer external; dcl iox_$user_output pointer external; /* format: off */ dcl (emf_et_$address_not_found, emf_et_$empty_address_list_field, error_table_$bad_arg, error_table_$badopt, error_table_$inconsistent, error_table_$noarg, error_table_$smallarg, error_table_$too_many_args, mlsys_et_$ca_parse_failed, mlsys_et_$no_recipients) fixed binary (35) external; /* format: on */ dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$cl entry (bit (36) aligned); dcl cu_$generate_call entry (entry, pointer); dcl cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned); dcl mail_system_$copy_address_list entry (pointer, pointer, fixed binary (35)); dcl mail_system_$delete_address entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$delete_reply_reference entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$free_address_list entry (pointer, fixed binary (35)); dcl mail_system_$merge_address_lists entry (pointer, pointer, bit (1) aligned, pointer, fixed binary (35)); dcl mail_system_$replace_bcc entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_cc entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_from entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_reply_to entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_subject entry (pointer, character (*), fixed binary (35)); dcl mail_system_$replace_to entry (pointer, pointer, fixed binary (35)); dcl mlsys_utils_$parse_address_list_control_args entry (pointer, fixed binary, pointer, character (8), pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_address_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_id_field entry (character (*) varying, bit (72) aligned, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_text_field entry (character (*) varying, character (*), bit (1) aligned, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$summarize_address entry (pointer, bit (1) aligned, character (*) varying, fixed binary (35)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21)); dcl cleanup condition; dcl (addr, baseno, index, length, null, stackframeptr, string, unspec) builtin; %page; /* The "from", "reply_to", "to", "cc", and "bcc" requests: When given no arguments, these requests print the specified field; when given arguments, these requests add the supplied addresses to the specified field */ from_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); address_list_field_value = message.from; fieldname = FROM_FIELDNAME; replace_field = mail_system_$replace_from; go to PROCESS_ADDRESS_LIST_FIELD_REQUEST; reply_to_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); address_list_field_value = message.reply_to; fieldname = REPLY_TO_FIELDNAME; replace_field = mail_system_$replace_reply_to; go to PROCESS_ADDRESS_LIST_FIELD_REQUEST; to_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); address_list_field_value = message.to; fieldname = TO_FIELDNAME; replace_field = mail_system_$replace_to; go to PROCESS_ADDRESS_LIST_FIELD_REQUEST; cc_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); address_list_field_value = message.cc; fieldname = CC_FIELDNAME; replace_field = mail_system_$replace_cc; go to PROCESS_ADDRESS_LIST_FIELD_REQUEST; bcc_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); address_list_field_value = message.bcc; fieldname = BCC_FIELDNAME; replace_field = mail_system_$replace_bcc; go to PROCESS_ADDRESS_LIST_FIELD_REQUEST; /* Process the request */ PROCESS_ADDRESS_LIST_FIELD_REQUEST: if n_arguments = 0 then do; /* No arguments: display the present content of the field */ if is_empty_list (address_list_field_value) then /*** Special display format if the list is empty ... */ if fieldname = FROM_FIELDNAME then do; /* ... except for the From field which has a default */ call mlsys_utils_$print_address_list_field (FROM_FIELDNAME, sdm_data_$default_from_field, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to display the default From field."); end; else call ioa_ ("^a: ", fieldname); else do; /* there are addresses in it */ call mlsys_utils_$print_address_list_field (fieldname, address_list_field_value, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to display the ^a field.", fieldname); end; end; else do; /* Arguments supplied: add the given addresses to the field */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = CREATE_AND_ANNOUNCE_MAILBOX; local_pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX; local_pcao.abort_on_errors = "0"b; /* in case -no_abort is used */ local_pcao.validate_addresses = "1"b; local_pcao.mbz = ""b; abort = "1"b; /* do not add any addresses if some are invalid */ found_invalid_address = "0"b; /* assume everthing's OK */ new_addresses_ptr, /* for cleanup handler */ savebox_addresses_ptr = null (); on condition (cleanup) call release_address_list_request_data (); argument_idx = 1; /* start at the beginning */ do while (argument_idx <= n_arguments); call mlsys_utils_$parse_address_list_control_args (sci_ptr, argument_idx, addr (local_pcao), ADDRESS_LIST_VERSION_2, new_addresses_ptr, savebox_addresses_ptr, code); if (code ^= 0) & (code ^= mlsys_et_$ca_parse_failed) then call ssu_$abort_line (sci_ptr, code, "Parsing control arguments."); found_invalid_address = found_invalid_address | (code = mlsys_et_$ca_parse_failed); if argument_idx <= n_arguments then do; /*** An argument not recognized by the mail system: must be one of ours */ call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if argument = "-abort" then abort = "1"b; else if argument = "-no_abort" then abort = "0"b; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a""", argument); argument_idx = argument_idx + 1; /* continue with next argument (if any) */ end; end; if is_empty_list (new_addresses_ptr) & is_empty_list (savebox_addresses_ptr) then call ssu_$abort_line (sci_ptr, error_table_$noarg, "New addresses for the ^a field.", fieldname); /*** Abort now if there are invalid addresses unless -no_abort was specified */ if abort & found_invalid_address then /* ... all appropriate messages were already printed */ call ssu_$abort_line (sci_ptr, 0); /*** Add the new addresses to the field */ if ^is_empty_list (new_addresses_ptr) then do; call mail_system_$merge_address_lists (address_list_field_value, new_addresses_ptr, "0"b, new_addresses_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding the new addresses to the ^a field.", fieldname); call replace_field (message_ptr, new_addresses_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding the new addresses to the ^a field.", fieldname); end; /*** Add any logbox/savebox addresses to the bcc field */ if ^is_empty_list (savebox_addresses_ptr) then do; call mail_system_$merge_address_lists (message.bcc, savebox_addresses_ptr, "0"b, savebox_addresses_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding the savebox addresses to the ^a field.", BCC_FIELDNAME); call mail_system_$replace_bcc (message_ptr, savebox_addresses_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding logbox and/or savebox addresses to the ^a field.", BCC_FIELDNAME); end; if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; /*** Cleanup */ call release_address_list_request_data (); end; return; /* Frees any address lists or addresses used by these requests which have not already been released */ release_address_list_request_data: procedure (); if savebox_addresses_ptr ^= null () then call mail_system_$free_address_list (savebox_addresses_ptr, (0)); if new_addresses_ptr ^= null () then call mail_system_$free_address_list (new_addresses_ptr, (0)); return; end release_address_list_request_data; %page; /* The "subject" request: When given no arguments, this request displays the current subject; when given arguments, this request replaces the subject. As an active request, it returns the current subject */ subject_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("1"b); if active_request then do; /* Active request: return the current subject */ if n_arguments = 0 then if message.subject.text_lth = 0 then /*** No subject: return "" to hold our place on the request line */ return_value = """"""; else return_value = requote_string_ (message_subject); else call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "No arguments are permitted when used as an active request."); end; else if n_arguments = 0 then do; /* Command request with no arguments: print the subject */ if message.subject.text_lth = 0 then call ioa_ ("^a: ", SUBJECT_FIELDNAME); else do; call mlsys_utils_$print_text_field (SUBJECT_FIELDNAME, message_subject, "0"b /* single-line field */, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to display the message subject."); end; end; else do; /* Command request with arguments supplied: change the subject */ new_subject_ptr = null (); /* for cleanup handler */ on condition (cleanup) begin; if new_subject_ptr ^= null () then if baseno (new_subject_ptr) ^= baseno (stackframeptr ()) then call ssu_$release_temp_segment (sci_ptr, new_subject_ptr); end; /*** Compute the length of the new subject */ new_subject_lth = n_arguments - 1; /* ... spaces between the words */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); new_subject_lth = new_subject_lth + argument_lth; end; /*** Use the stack if the new subject is short enough; otherwise, build it in a temporary segment */ if new_subject_lth <= (4 * STACK_EXTENSION) then call cu_$grow_stack_frame (STACK_EXTENSION, new_subject_ptr, (0)); else call ssu_$get_temp_segment (sci_ptr, "subject-text", new_subject_ptr); /*** Build the new subject */ new_subject_used = 0; do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); begin; dcl inserted_text character (argument_lth) unaligned defined (new_subject) position (new_subject_used + 1); inserted_text = argument; end; new_subject_used = new_subject_used + argument_lth; if argument_idx < n_arguments then do; begin; dcl inserted_space character (1) unaligned defined (new_subject) position (new_subject_used + 1); inserted_space = " "; end; new_subject_used = new_subject_used + 1; end; end; /*** Replace the subject in the message */ call mail_system_$replace_subject (message_ptr, new_subject, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Replacing the message subject."); if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; /*** Cleanup */ if new_subject_ptr ^= null () then if baseno (new_subject_ptr) ^= baseno (stackframeptr ()) then call ssu_$release_temp_segment (sci_ptr, new_subject_ptr); end; return; %page; /* The "message_id" requests: prints the unique identifier associated with the message. This request has knowledge of the internal format of message identifiers used by the mail system and mail fail if said format changes */ message_id_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); if n_arguments > 0 then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "No arguments are permitted."); call mlsys_utils_$print_message_id_field (MESSAGE_ID_FIELDNAME, unspec (sdm_invocation.date_time_body_modified), 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Attempting to print the ^a field.", MESSAGE_ID_FIELDNAME); return; %page; /* The "remove" request: Deletes the specified addresses from the approriate header fields; any addresses given before the use of a field selection control argument (-from, etc.) will be deleted from all of the recipient fields (To, cc, bcc). Control arguments to delete the message subject and list of reply references are also accepted */ remove_request: entry (P_sci_ptr, P_sdm_invocation_ptr); call setup_request ("0"b); if n_arguments = 0 then call ssu_$abort_line (sci_ptr, 0, "Usage: remove {addresses} {-control_args}"); /* Argument processing */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode, local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = "1"b; /* stop immediately on syntax errors */ local_pcao.validate_addresses = "0"b; /* have to be able to delete non-existant addresses */ local_pcao.mbz = ""b; current_address_list_ptr_ptr = addr (lists.recipients); /* start by deleting recipients */ lists = null (); /* no addresses to be deleted yet */ string (all) = ""b; /* haven't yet been asked to flush all addresses in a field */ remove_subject, remove_in_reply_to = "0"b; new_address_list_field_value, /* for cleanup handler */ new_to_field_value, new_cc_field_value, new_bcc_field_value = null (); on condition (cleanup) call release_remove_request_data (); argument_idx = 1; /* start at the beginning */ do while (argument_idx <= n_arguments); call mlsys_utils_$parse_address_list_control_args (sci_ptr, argument_idx, addr (local_pcao), ADDRESS_LIST_VERSION_2, current_address_list_ptr, lists.bcc, code); if (code ^= 0) & (code ^= mlsys_et_$ca_parse_failed) then call ssu_$abort_line (sci_ptr, code, "Parsing control arguments."); if argument_idx <= n_arguments then do; /*** An argument not recognized by the mail system: must be one of ours */ call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-all") | (argument = "-a") then if current_address_list_ptr_ptr = addr (lists.recipients) then all.recipients = "1"b; else call ssu_$abort_line (sci_ptr, 0, """-all"" must appear immediately after ""-from"", etc."); else if (argument = "-subject") | (argument = "-sj") then remove_subject = "1"b; else if (argument = "-in_reply_to") | (argument = "-irt") then remove_in_reply_to = "1"b; /*** Following control argument is no longer valid: delete in MR11.0 */ else if (argument = "-message_id") | (argument = "-mid") then ; else if argument = "-from" then do; if argument_idx = n_arguments then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Addresses or ""-all"" after ""-from""."); call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), next_argument_ptr, next_argument_lth); if (next_argument = "-all") | (next_argument = "-a") then do; all.from = "1"b; /* ... delete the entire field's content */ argument_idx = argument_idx + 1; end; else current_address_list_ptr_ptr = addr (lists.from); end; else if (argument = "-reply_to") | (argument = "-rpt") then do; if argument_idx = n_arguments then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Addresses or ""-all"" after ""-reply_to""."); call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), next_argument_ptr, next_argument_lth); if (next_argument = "-all") | (next_argument = "-a") then do; all.reply_to = "1"b; /* ... delete the entire field's content */ argument_idx = argument_idx + 1; end; else current_address_list_ptr_ptr = addr (lists.reply_to); end; else if argument = "-to" then do; if argument_idx = n_arguments then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Addresses or ""-all"" after ""-to""."); call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), next_argument_ptr, next_argument_lth); if (next_argument = "-all") | (next_argument = "-a") then do; all.to = "1"b; /* ... delete the entire field's content */ argument_idx = argument_idx + 1; end; else current_address_list_ptr_ptr = addr (lists.to); end; else if argument = "-cc" then do; if argument_idx = n_arguments then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Addresses or ""-all"" after ""-cc""."); call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), next_argument_ptr, next_argument_lth); if (next_argument = "-all") | (next_argument = "-a") then do; all.cc = "1"b; /* ... delete the entire field's content */ argument_idx = argument_idx + 1; end; else current_address_list_ptr_ptr = addr (lists.cc); end; else if argument = "-bcc" then do; if argument_idx = n_arguments then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Addresses or ""-all"" after ""-bcc""."); call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), next_argument_ptr, next_argument_lth); if (next_argument = "-all") | (next_argument = "-a") then do; all.bcc = "1"b; /* ... delete the entire field's content */ argument_idx = argument_idx + 1; end; else current_address_list_ptr_ptr = addr (lists.bcc); end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, """^a""", argument); argument_idx = argument_idx + 1; /* continue with next argument (if any) */ end; end; if all.recipients & ^is_empty_list (lists.recipients) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Addresses and ""-all""."); if all.from & ^is_empty_list (lists.from) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Addresses and ""-all"" after ""-from""."); if all.reply_to & ^is_empty_list (lists.reply_to) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Addresses and ""-all"" after ""-reply_to""."); if all.to & ^is_empty_list (lists.to) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Addresses and ""-all"" after ""-to""."); if all.cc & ^is_empty_list (lists.cc) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Addresses and ""-all"" after ""-cc""."); if all.bcc & ^is_empty_list (lists.bcc) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Addresses and ""-all"" after ""-bcc""."); /* Process the non-address list fields */ errors_detected = "0"b; /* remember if anything ever goes wrong */ if remove_subject then do; call mail_system_$replace_subject (message_ptr, "", code); if code = 0 then /* ... success */ if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Deleting the ^a field.", SUBJECT_FIELDNAME); end; if remove_in_reply_to then do; /* remove all reply references */ code = 0; /* ... need do until */ do idx = message.n_reply_references to 1 by -1 while (code = 0); call mail_system_$delete_reply_reference (message_ptr, idx, code); if code ^= 0 then call report_error (sci_ptr, code, "Deleting the ^a field.", REPLY_REFERENCES_FIELDNAME); end; sdm_invocation.original_messages_ptr = null (); if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; end; /* Delete the requested recipients from the To, cc, and bcc fields */ if all.recipients then do; /*** Delete all recipients */ call mail_system_$replace_to (message_ptr, null (), code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Deleting the contents of the ^a field.", TO_FIELDNAME); call mail_system_$replace_cc (message_ptr, null (), code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Deleting the contents of the ^a field.", CC_FIELDNAME); call mail_system_$replace_bcc (message_ptr, null (), code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Deleting the contents of the ^a field.", BCC_FIELDNAME); end; else if ^is_empty_list (lists.recipients) then do; /*** Delete only the specified recipients */ if is_empty_list (message.to) & is_empty_list (message.cc) & is_empty_list (message.bcc) then call report_error (sci_ptr, mlsys_et_$no_recipients); else do; replace_to_field, replace_cc_field, replace_bcc_field = "0"b; call mail_system_$copy_address_list (message.to, new_to_field_value, (0)); call mail_system_$copy_address_list (message.cc, new_cc_field_value, (0)); call mail_system_$copy_address_list (message.bcc, new_bcc_field_value, (0)); do address_idx = 1 to lists.recipients -> address_list.n_addresses; the_address = lists.recipients -> address_list.addresses (address_idx); address_deleted = "0"b; /*** Delete it from the To field ... */ idx = 1; do while (idx <= new_to_field_value -> address_list.n_addresses); if mail_system_$compare_addresses (the_address, new_to_field_value -> address_list.addresses (idx), (0)) then do; replace_to_field, address_deleted = "1"b; call mail_system_$delete_address (new_to_field_value, idx, code); if code ^= 0 then call report_error (sci_ptr, code, "Attempting to delete an address from the ^a field.", TO_FIELDNAME); end; else idx = idx + 1; /* ... no match: proceeed to next candidate */ end; /*** Delete it from the cc field ... */ idx = 1; do while (idx <= new_cc_field_value -> address_list.n_addresses); if mail_system_$compare_addresses (the_address, new_cc_field_value -> address_list.addresses (idx), (0)) then do; replace_cc_field, address_deleted = "1"b; call mail_system_$delete_address (new_cc_field_value, idx, code); if code ^= 0 then call report_error (sci_ptr, code, "Attempting to delete an address from the ^a field.", CC_FIELDNAME); end; else idx = idx + 1; /* ... no match: proceeed to next candidate */ end; /*** Delete it from the bcc field ... */ idx = 1; do while (idx <= new_bcc_field_value -> address_list.n_addresses); if mail_system_$compare_addresses (the_address, new_bcc_field_value -> address_list.addresses (idx), (0)) then do; replace_bcc_field, address_deleted = "1"b; call mail_system_$delete_address (new_bcc_field_value, idx, code); if code ^= 0 then call report_error (sci_ptr, code, "Attempting to delete an address from the ^a field.", BCC_FIELDNAME); end; else idx = idx + 1; /* ... no match: proceeed to next candidate */ end; if ^address_deleted then call report_address_not_deleted (""); end; /*** Update the recipient fields as appropriate ... */ if replace_to_field then do; /* we've changed the To field */ call mail_system_$replace_to (message_ptr, new_to_field_value, code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Replacing the ^a field.", TO_FIELDNAME); end; if replace_cc_field then do; /* we've changed the cc field */ call mail_system_$replace_cc (message_ptr, new_cc_field_value, code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Replacing the ^a field.", CC_FIELDNAME); end; if replace_bcc_field then do; /* we've changed the bcc field */ call mail_system_$replace_bcc (message_ptr, new_bcc_field_value, code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Replacing the ^a field.", BCC_FIELDNAME); end; if new_to_field_value ^= null () then call mail_system_$free_address_list (new_to_field_value, (0)); if new_cc_field_value ^= null () then call mail_system_$free_address_list (new_cc_field_value, (0)); if new_bcc_field_value ^= null () then call mail_system_$free_address_list (new_bcc_field_value, (0)); end; end; /* Process the individual address lists */ call process_remove_for_field (FROM_FIELDNAME, message.from, mail_system_$replace_from, lists.from, all.from); call process_remove_for_field (REPLY_TO_FIELDNAME, message.reply_to, mail_system_$replace_reply_to, lists.reply_to, all.reply_to); call process_remove_for_field (TO_FIELDNAME, message.to, mail_system_$replace_to, lists.to, all.to); call process_remove_for_field (CC_FIELDNAME, message.cc, mail_system_$replace_cc, lists.cc, all.cc); call process_remove_for_field (BCC_FIELDNAME, message.bcc, mail_system_$replace_bcc, lists.bcc, all.bcc); /* Clean up */ call release_remove_request_data (); if errors_detected then call ssu_$abort_line (sci_ptr, 0); return; /* Deletes either the entire contents of the specified address list field or all occurences of the supplied addresses */ process_remove_for_field: procedure (p_fieldname, p_field_value, p_replace_field, p_addresses_to_remove, p_remove_all_addresses); dcl p_fieldname character (*) varying parameter; dcl p_field_value pointer parameter; dcl p_replace_field entry (pointer, pointer, fixed binary (35)) variable parameter; dcl p_addresses_to_remove pointer parameter; dcl p_remove_all_addresses bit (1) aligned parameter; dcl (replace_the_field, address_deleted) bit (1) aligned; dcl (address_idx, idx) fixed binary; if p_remove_all_addresses then do; /*** Delete the entire field's content */ call p_replace_field (message_ptr, null (), code); if code = 0 then /* ... we've changed the message */ if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Deleting the contents of the ^a field.", p_fieldname); end; else if ^is_empty_list (p_addresses_to_remove) then do; /*** Delete the specified addresses from the field */ if is_empty_list (p_field_value) then call report_error (sci_ptr, emf_et_$empty_address_list_field, "Can not remove any addresses from the ^a field.", p_fieldname); else do; replace_the_field = "0"b; /* until we've actually changed it */ call mail_system_$copy_address_list (p_field_value, new_address_list_field_value, (0)); do address_idx = 1 to p_addresses_to_remove -> address_list.n_addresses; the_address = p_addresses_to_remove -> address_list.addresses (address_idx); address_deleted = "0"b; idx = 1; do while (idx <= new_address_list_field_value -> address_list.n_addresses); if mail_system_$compare_addresses (the_address, new_address_list_field_value -> address_list.addresses (idx), (0)) then do; address_deleted = "1"b; /* ... don't report that it wasn't found */ call mail_system_$delete_address (new_address_list_field_value, idx, code); if code ^= 0 then call report_error (sci_ptr, code, "Attempting to delete an address from the ^a field.", p_fieldname); end; else idx = idx + 1; /* ... no match: proceeed to next candidate */ end; if address_deleted then replace_the_field = "1"b; else call report_address_not_deleted (p_fieldname); end; if replace_the_field then do; /* we've made some changes */ call p_replace_field (message_ptr, new_address_list_field_value, code); if code = 0 then if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; else ; else call report_error (sci_ptr, code, "Replacing the ^a field.", p_fieldname); end; if new_address_list_field_value ^= null () then call mail_system_$free_address_list (new_address_list_field_value, (0)); end; end; return; end process_remove_for_field; /* Reports that the given address was not found in the specified address list field */ report_address_not_deleted: procedure (p_fieldname) options (non_quick); dcl p_fieldname character (*) varying parameter; dcl address_summary character (address_summary_max_lth) varying based (address_summary_ptr); dcl address_summary_ptr pointer; dcl address_summary_max_lth fixed binary (21); call cu_$grow_stack_frame (STACK_EXTENSION, address_summary_ptr, (0)); address_summary_max_lth = 4 * (STACK_EXTENSION - 1); code = error_table_$smallarg; /* need do until ... */ do while (code = error_table_$smallarg); /* ... until the buffer's large enough to hold it */ call mlsys_utils_$summarize_address (the_address, "1"b /* beginning of sentence */, address_summary, code); if code = error_table_$smallarg then do; call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0)); address_summary_max_lth = address_summary_max_lth + (4 * STACK_EXTENSION); end; end; if length (p_fieldname) = 0 then call report_error (sci_ptr, emf_et_$address_not_found, "^a in the To, cc, or bcc fields.", address_summary) ; else call report_error (sci_ptr, emf_et_$address_not_found, "^a in the ^a field.", address_summary, p_fieldname) ; return; end report_address_not_deleted; /* Reports an error by calling ssu_$print_message: The global flag indicating that an error was detected is set in order to insure that the request line is aborted after processing of this remove request is completed */ report_error: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); errors_detected = "1"b; if sdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; return; end report_error; /* Releases the temporary address lists used by the remove request */ release_remove_request_data: procedure (); if new_bcc_field_value ^= null () then call mail_system_$free_address_list (new_bcc_field_value, (0)); if new_cc_field_value ^= null () then call mail_system_$free_address_list (new_cc_field_value, (0)); if new_to_field_value ^= null () then call mail_system_$free_address_list (new_to_field_value, (0)); if new_address_list_field_value ^= null () then call mail_system_$free_address_list (new_address_list_field_value, (0)); if lists.recipients ^= null () then call mail_system_$free_address_list (lists.recipients, (0)); if lists.from ^= null () then call mail_system_$free_address_list (lists.from, (0)); if lists.reply_to ^= null () then call mail_system_$free_address_list (lists.reply_to, (0)); if lists.to ^= null () then call mail_system_$free_address_list (lists.to, (0)); if lists.cc ^= null () then call mail_system_$free_address_list (lists.cc, (0)); if lists.bcc ^= null () then call mail_system_$free_address_list (lists.bcc, (0)); return; end release_remove_request_data; %page; /* Performs initialization common to all requests */ setup_request: procedure (p_allow_active_request); dcl p_allow_active_request bit (1) aligned; sci_ptr = P_sci_ptr; if p_allow_active_request then /* use appropriate mechanism to get argument count, etc. */ call ssu_$return_arg (sci_ptr, n_arguments, active_request, return_value_ptr, return_value_max_lth); else call ssu_$arg_count (sci_ptr, n_arguments); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; return; end setup_request; /* Determines if the given address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* if there's no data at all, it's empty */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; %page; %include sdm_invocation; %page; %include sdm_data; %page; %include send_mail_options; %page; %include mlsys_message; %page; %include mlsys_address_list; %page; %include mlsys_parse_ca_options; %page; %include mlsys_field_names; end sdm_header_requests_;  sdm_mbx_requests_.pl1 10/02/89 0908.5rew 10/02/89 0819.8 201690 /****^ *********************************************************** * * * 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-03-22,Blair), approve(88-03-22,MCR7842), audit(88-06-28,Lippard), install(88-07-26,MR12.2-1069): Look for the savebox using the mlsys search_list before querying the user for whether or not he wishes to create a new mbx on a save request. The copy also uses the searchlist to locate mailboxes, but the mailbox must exist for the request to succeed. 2) change(89-06-23,Lee), approve(89-07-11,MCR8120), audit(89-08-27,LZimmerman), install(89-10-02,MR12.3-1079): phx19035 (Mail 460) - fixed bug in send_mail's "enter" request which causes mail to be sent when invalid or missing arguments are supplied for address control arguments. END HISTORY COMMENTS */ /* format: off */ /* The send_mail send, log, save, and copy requests */ /* Created: 2 January 1979 by G. Palter */ /* Modified: 9 January 1979 by G. Palter to add log, save, and copy requests */ /* Modified: 12 January 1978 by G. Palter to not regard options to send as changing the identity of the message */ /* Modified: 15 January 1979 by G. Palter to add "-abort"/"-no_abort" to the send request */ /* Modified: 7 February 1979 by G. Palter to not set acknowledge bit for log, save, and copy requests */ /* Modified: 16 March 1979 by G. Palter to not send, log, or save the message if there is no text */ /* Modified: 2 June 1980 by G. Palter to fix bug #0304 -- the "write", "append", and "preface" requests should validate the name of the segment. For example, they should reject the name "x." */ /* Modified: September 1983 by G. Palter as part of the conversion to the new mail system interface */ /* Modified: April 1984 by G. Palter to fix mail system error #0433 -- the send_mail command and all send_mail and read_mail requests which accept multiple addresses as arguments do not properly parse "-log -at HOST" */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_mbx_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); return; /* not an entrypoint */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl error_table_$noentry fixed bin(35) ext static; dcl 1 local_pcao aligned like parse_ca_options; dcl 1 local_do aligned like deliver_options; dcl 1 local_ri aligned, /* describes the message's recipients ... */ 2 header like recipients_info.header, 2 lists (3) like recipients_info.lists; /* ... enough for the To, cc, and bcc fields */ dcl explicit_address_list_ptr pointer; /* -> list of recipients on the send request line */ dcl address_ptr pointer; dcl (address_idx, address_type) fixed binary; dcl mbx_dirname character (168); dcl mbx_ename character (32); dcl brief bit (1) aligned; dcl try_to_create bit (1); dcl invalid_address_found bit (1); dcl code fixed binary (35); /* format: off */ dcl (error_table_$bad_arg, error_table_$badopt, error_table_$nostars, mlsys_et_$ca_parse_failed, mlsys_et_$empty_message, mlsys_et_$logbox_created, mlsys_et_$message_not_sent, mlsys_et_$message_partially_sent, mlsys_et_$no_mailbox, mlsys_et_$no_recipients, mlsys_et_$no_savebox, mlsys_et_$savebox_created) fixed binary (35) external; /* format: on */ dcl check_star_name_$entry entry (character (*), fixed binary (35)); dcl command_query_$yes_no entry () options (variable); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl get_system_free_area_ entry () returns (pointer); dcl mail_system_$copy_message entry (pointer, character (*), character (*), fixed binary (35)); dcl mail_system_$deliver_message entry (pointer, pointer, pointer, fixed binary (35)); dcl mail_system_$free_address_list entry (pointer, fixed binary (35)); dcl mail_system_$get_address_pathname entry (pointer, character (*), character (*), character (*), fixed binary (35)); dcl mail_system_$get_address_type entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$log_message entry (pointer, bit (1) aligned, fixed binary (35)); dcl mail_system_$save_message entry (pointer, character (*), character (*), bit (1) aligned, fixed binary (35)); dcl mail_system_$validate_address entry (pointer, bit (1) aligned, fixed binary (35)); dcl mlsys_utils_$create_logbox entry (fixed binary (35)); dcl mlsys_utils_$create_savebox entry (character (*), character (*), fixed binary (35)); dcl mlsys_utils_$free_delivery_results entry (pointer, fixed binary (35)); dcl mlsys_utils_$parse_address_list_control_args entry (pointer, fixed binary, pointer, character (8), pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_delivery_results entry (pointer, bit (1) aligned, pointer, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl search_paths_$find_dir entry (char(*), ptr, char(*), char(*), char(*), fixed bin(35)); dcl suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$print_message entry () options (variable); dcl cleanup condition; dcl (addr, index, length, null, reverse, search, string) builtin; %page; /* The "send" request: transmits the message either to the addresses listed in the To, cc, and bcc fields or to the addresses given on the request line */ send_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); explicit_address_list_ptr, /* for cleanup handler */ local_ri.expanded_recipients_result_list_ptr, local_ri.lists (*) = null (); on condition (cleanup) call cleanup_after_send_request (); /*** Setup delivery options */ local_do.version = DELIVER_OPTIONS_VERSION_2; local_do.delivery_mode = ORDINARY_DELIVERY; /* ... an ordinary message */ local_do.queueing_mode = ALWAYS_QUEUE_FOREIGN; /* ... always queue foreign addresses & local when needed */ local_do.queued_notification_mode = NOTIFY_ON_ERROR; string (local_do.flags) = ""b; local_do.abort = "1"b; /* ... default to not send if everyone can't get the copy */ local_do.recipient_notification = sdm_invocation.notify; local_do.acknowledge = sdm_invocation.acknowledge; local_ri.version = RECIPIENTS_INFO_VERSION_2; local_ri.area_ptr = get_system_free_area_ (); local_ri.n_lists = 0; /* ... haven't decided which lists yet */ /* Argument processing */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = CREATE_AND_ANNOUNCE_MAILBOX; local_pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX; local_pcao.abort_on_errors = "0"b; /* ... can't abort in case -no_abort appears somewhere */ local_pcao.validate_addresses = "0"b; /* ... deliver_message entrypoint will do the validation */ local_pcao.mbz = "0"b; brief = sdm_invocation.brief; /* defaults to what was given on the command line */ invalid_address_found = "0"b; /* phx19035, RL: to determine handling of -abort/-no_abort */ argument_idx = 1; /* start at the beginning */ do while (argument_idx <= n_arguments); call mlsys_utils_$parse_address_list_control_args (P_sci_ptr, argument_idx, addr (local_pcao), ADDRESS_LIST_VERSION_2, explicit_address_list_ptr, explicit_address_list_ptr, code); if (code ^= 0) & (code ^= mlsys_et_$ca_parse_failed) then call ssu_$abort_line (P_sci_ptr, code, "Parsing control arguments."); /* phx19035 RL: Note invalid addresses for possible later abort */ invalid_address_found = invalid_address_found | (code = mlsys_et_$ca_parse_failed); if argument_idx <= n_arguments then do; /*** An argument not recognized by the mail system: must be one of ours */ call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if argument = "-abort" then local_do.abort = "1"b; else if argument = "-no_abort" then local_do.abort = "0"b; else if (argument = "-acknowledge") | (argument = "-ack") then local_do.acknowledge = "1"b; else if (argument = "-no_acknowledge") | (argument = "-nack") then local_do.acknowledge = "0"b; else if (argument = "-brief") | (argument = "-bf") then brief = "1"b; else if (argument = "-long") | (argument = "-lg") then brief = "0"b; else if (argument = "-notify") | (argument = "-nt") then local_do.recipient_notification = "1"b; else if (argument = "-no_notify") | (argument = "-nnt") then local_do.recipient_notification = "0"b; /*** Control arguments which are now obsolete: delete in MR11 */ else if (argument = "-header") | (argument = "-he") | (argument = "-no_header") | (argument = "-nhe") then ; else if (argument = "-message_id") | (argument = "-mid") | (argument = "-no_message_id") | (argument = "-nmid") then ; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, error_table_$bad_arg, """^a""", argument); argument_idx = argument_idx + 1; /* continue with next argument (if any) */ end; end; /* phx19035 RL: Abort delivery if invalid addresses found and -no_abort not specified */ if invalid_address_found & local_do.abort then call ssu_$abort_line (P_sci_ptr, 0); /* Scan the explicit recipients for logbox and save box addresses: Create the logbox if necessary and ask for permission to create any saveboxes */ if ^is_empty_list (explicit_address_list_ptr) then do; address_list_ptr = explicit_address_list_ptr; do address_idx = 1 to address_list.n_addresses; address_ptr = address_list.addresses (address_idx); call mail_system_$get_address_type (address_ptr, address_type, (0)); if (address_type = LOGBOX_ADDRESS) | (address_type = SAVEBOX_ADDRESS) then do; call mail_system_$get_address_pathname (address_ptr, mbx_dirname, mbx_ename, ((32)" "), (0)); call mail_system_$validate_address (address_ptr, "0"b /* don't expand mailing lists */, code); if code = mlsys_et_$no_mailbox then do; if address_type = LOGBOX_ADDRESS then do; call mlsys_utils_$create_logbox (code); if code = 0 then call ssu_$print_message (P_sci_ptr, 0, "Created ^a.", pathname_ (mbx_dirname, mbx_ename)); else if local_do.abort then call ssu_$abort_line (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); else call ssu_$print_message (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); end; else /*** if address_type = SAVEBOX_ADDRESS then */ do; call command_query_$yes_no (try_to_create, 0, ssu_$get_subsystem_and_request_name (P_sci_ptr), "", "Do you wish to create the savebox ^a?", pathname_ (mbx_dirname, mbx_ename)); if try_to_create then do; call mlsys_utils_$create_savebox (mbx_dirname, mbx_ename, code); if code ^= 0 then /* ... report the failure */ if local_do.abort then call ssu_$abort_line (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); else call ssu_$print_message (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); else if local_do.abort then call ssu_$abort_line (P_sci_ptr, 0); end; end; end; end; end; end; /* Setup the list(s) of recipients for the message */ if is_empty_list (explicit_address_list_ptr) then do; /*** Use the To, cc, and bcc fields */ local_ri.n_lists = 0; if ^is_empty_list (message.to) then do; local_ri.n_lists = local_ri.n_lists + 1; local_ri.lists (local_ri.n_lists).address_list_ptr = message.to; end; if ^is_empty_list (message.cc) then do; local_ri.n_lists = local_ri.n_lists + 1; local_ri.lists (local_ri.n_lists).address_list_ptr = message.cc; end; if ^is_empty_list (message.bcc) then do; local_ri.n_lists = local_ri.n_lists + 1; local_ri.lists (local_ri.n_lists).address_list_ptr = message.bcc; end; if local_ri.n_lists = 0 then /* no recipients ... */ call ssu_$abort_line (P_sci_ptr, mlsys_et_$no_recipients); end; else do; /*** Use the addresses supplied on the request line */ local_ri.n_lists = 1; local_ri.lists (1).address_list_ptr = explicit_address_list_ptr; end; /* Deliver the message and report the results */ call mail_system_$deliver_message (message_ptr, addr (local_ri), addr (local_do), code); if (code ^= 0) & (code ^= mlsys_et_$message_not_sent) & (code ^= mlsys_et_$message_partially_sent) then call ssu_$abort_line (P_sci_ptr, code, "Attempting to transmit the message."); call mlsys_utils_$print_delivery_results (P_sci_ptr, brief, addr (local_ri), (0)); call cleanup_after_send_request (); /* flush the data */ if (code = 0) | (code = mlsys_et_$message_partially_sent) then sdm_invocation.message_state = PROCESSED_MESSAGE; /* allow quit without query if it got through to anyone */ if code ^= 0 then /* abort the line because of errors in the transmission */ call ssu_$abort_line (P_sci_ptr, code); return; /* Release the data structures used by the send request */ cleanup_after_send_request: procedure (); call mlsys_utils_$free_delivery_results (addr (local_ri), (0)); if explicit_address_list_ptr ^= null () then call mail_system_$free_address_list (explicit_address_list_ptr, (0)); return; end cleanup_after_send_request; %page; /* The "log" request: places a copy of the message into the user's logbox which is created if necessary */ log_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (P_sci_ptr, 0, "No arguments may be given."); call abort_if_body_is_empty (); call mail_system_$log_message (message_ptr, "1"b /* create if not found */, code); if code = mlsys_et_$logbox_created then do; /* announce that we just created the user's logbox */ call mail_system_$get_address_pathname (mlsys_data_$user_logbox_address, mbx_dirname, mbx_ename, ((32)" "), (0)); call ssu_$print_message (P_sci_ptr, 0, "Created ^a.", pathname_ (mbx_dirname, mbx_ename)); code = 0; /* ... make the code indicate success */ end; if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Adding the message to your logbox."); sdm_invocation.message_state = PROCESSED_MESSAGE; /* the user can now quit without query */ return; %page; /* The "save" request: places a copy of the message into the specified savebox; the user is queried for permission to create the savebox if it does not exist */ save_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments ^= 1 then call ssu_$abort_line (P_sci_ptr, 0, "Usage: save path"); call ssu_$arg_ptr (P_sci_ptr, 1, argument_ptr, argument_lth); if index (argument, "-") = 1 then call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); if index (reverse (argument), reverse (".sv")) = 1 then argument_lth = argument_lth - length (".sv"); /* remove ".sv" to avoid generating "x.sv.sv.mbx" */ if search (argument, "<>") > 0 then do; call expand_pathname_$add_suffix (argument, "sv.mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", argument); end; else do; call suffixed_name_$make (argument, "sv.mbx", mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", argument); call search_paths_$find_dir ("mlsys", null(), mbx_ename, "", mbx_dirname, code); if code ^= 0 then if code = error_table_$noentry then do; call expand_pathname_$add_suffix (argument, "sv.mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", argument); end; else call ssu_$abort_line (P_sci_ptr, code, "^a", mbx_ename); end; call check_star_name_$entry (mbx_ename, code); if code ^= 0 then /* reject invalid names and star names */ if (code = 1) | (code = 2) then call ssu_$abort_line (P_sci_ptr, error_table_$nostars, "^a", pathname_ (mbx_dirname, mbx_ename)); else call ssu_$abort_line (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); call abort_if_body_is_empty (); call mail_system_$save_message (message_ptr, mbx_dirname, mbx_ename, "0"b /* do not create if missing */, code); if code = mlsys_et_$no_savebox then do; /* ask for permission to create the savebox */ call command_query_$yes_no (try_to_create, 0, ssu_$get_subsystem_and_request_name (P_sci_ptr), "", "Do you wish to create the savebox ^a?", pathname_ (mbx_dirname, mbx_ename)); if try_to_create then /* ... permission given: try again */ call mail_system_$save_message (message_ptr, mbx_dirname, mbx_ename, "1"b /* create if not found */, code); else call ssu_$abort_line (P_sci_ptr, 0); /* ... no permission: stop right here */ if code = mlsys_et_$savebox_created then code = 0; end; if code ^= 0 then /* couldn't save it */ call ssu_$abort_line (P_sci_ptr, code, "Adding the message to the savebox ^a.", pathname_ (mbx_dirname, mbx_ename)); sdm_invocation.message_state = PROCESSED_MESSAGE; /* it's now OK to quit without query */ return; %page; /* The "copy" request: places a copy of the message into the specified mailbox which must already exist */ copy_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments ^= 1 then call ssu_$abort_line (P_sci_ptr, 0, "Usage: copy path"); call ssu_$arg_ptr (P_sci_ptr, 1, argument_ptr, argument_lth); if index (argument, "-") = 1 then call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); if search (argument, "<>") > 0 then do; call expand_pathname_$add_suffix (argument, "mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", argument); end; else do; call suffixed_name_$make (argument, "mbx", mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", argument); call search_paths_$find_dir ("mlsys", null (), mbx_ename, "", mbx_dirname, code); if code ^= 0 then if code = error_table_$noentry then do; call expand_pathname_$add_suffix (argument, "mbx", mbx_dirname, mbx_ename, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "^a", argument); end; else call ssu_$abort_line (P_sci_ptr, code, "^a", argument); end; call check_star_name_$entry (mbx_ename, code); if code ^= 0 then /* reject invalid names and star names */ if (code = 1) | (code = 2) then call ssu_$abort_line (P_sci_ptr, error_table_$nostars, "^a", pathname_ (mbx_dirname, mbx_ename)); else call ssu_$abort_line (P_sci_ptr, code, "^a", pathname_ (mbx_dirname, mbx_ename)); call abort_if_body_is_empty (); call mail_system_$copy_message (message_ptr, mbx_dirname, mbx_ename, code); if code ^= 0 then /* couldn't copy it */ call ssu_$abort_line (P_sci_ptr, code, "Adding the message to the mailbox ^a.", pathname_ (mbx_dirname, mbx_ename)); sdm_invocation.message_state = PROCESSED_MESSAGE; /* it's now OK to quit without query */ return; %page; /* Determines if the given address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* if there's no data at all, it's empty */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; /* Aborts the operation if the message is empty */ abort_if_body_is_empty: procedure (); dcl idx fixed binary; do idx = 1 to message.n_body_sections; message_body_section_ptr = addr (message.body_sections (idx)); if message_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION then if message_preformatted_body_section.text_lth > 0 then return; /* any non-zero length section => the message isn't empty */ else ; else /*** if message_body_section.section_type = MESSAGE_BIT_STRING_BODY_SECTION then */ if message_bit_string_body_section.bit_string_lth > 0 then return; end; /* any non-zero length section => the message isn't empty */ /*** Control arrives here iff all sections in the body are empty */ call ssu_$abort_line (P_sci_ptr, mlsys_et_$empty_message); end abort_if_body_is_empty; %page; %include sdm_invocation; %page; %include mlsys_data; %page; %include mlsys_message; %page; %include mlsys_address_list; %page; %include mlsys_address_types; %page; %include mlsys_deliver_info; %page; %include mlsys_parse_ca_options; end sdm_mbx_requests_;  sdm_misc_requests_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 56394 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* Miscellaneous send_mail requests */ /* Created: 1 January 1979 by G. Palter */ /* Modified: 23 January 1979 by G. Palter to slightly modify output of requests */ /* Modified: 5 May 1980 by W. Olin Sibert for new ssu_ interface */ /* Modified: 30 May 1980 by G. Palter to implement suggestion #0316 -- the "." requests should indicate if abbrev processing is enabled */ /* Modified: 4 June 1980 by G. Palter to implement suggestion #0287 -- if a reply is being created and the user exits send_mail without sending the reply, the "-delete" control argument of the "reply" request should be ignored */ /* Modified: 16 February 1982 by G. Palter for new calling sequence of ssu_$get_abbrev_info */ /* Modified: 18 September 1982 by G. Palter to rename dot_request to self_identify and make the quit request accept "-no_force" and an arbitrary number of arguments (for abbreviations) */ /* Modified: September 1983 by G. Palter as part of the conversion to the new mail system interface */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_misc_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); return; /* not an entry */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl (subsystem_name, subsystem_version) character (32); dcl subsystem_level fixed binary; dcl abbrev_enabled bit (1) aligned; dcl processing_state fixed binary (2); dcl request_name character (72); dcl question_idx fixed binary; dcl force bit (1); /* format: off */ dcl QUESTION (-1:1) character (128) varying static options (constant) initial ( "Message has not been sent, saved, or written.", "", /* processed message: should never be used */ "Message has been modified since it was last sent, saved, or written."); dcl (error_table_$bad_arg, error_table_$badopt, emf_et_$send_mail_aborted) fixed binary (35) external; /* format: on */ dcl command_query_$yes_no entry () options (variable); dcl ioa_ entry () options (variable); dcl ssu_$abort_line entry () options (variable); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$get_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned); dcl ssu_$get_invocation_count entry (pointer, fixed binary, fixed binary); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$get_subsystem_name entry (pointer) returns (character (32)); dcl ssu_$get_subsystem_version entry (pointer) returns (character (32)); dcl (addr, index, null) builtin; %page; /* format: off */ /* The "." request: prints a line of the form: send_mail V {(abbrev)} {(debug)} {(level R)}: N lines {(STATE)}; {Subject: STR} where items enclosed in {}'s are optionally printed if meaningfull */ /* format: on */ self_identify: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments ^= 0 then call ssu_$abort_line (P_sci_ptr, 0, "No arguments may be given."); subsystem_name = ssu_$get_subsystem_name (P_sci_ptr); subsystem_version = ssu_$get_subsystem_version (P_sci_ptr); call ssu_$get_abbrev_info (P_sci_ptr, (null ()), (null ()), abbrev_enabled); call ssu_$get_invocation_count (P_sci_ptr, subsystem_level, (0)); call ioa_ ( "^a ^a^[ (abbrev)^]^[ (debug)^]^[ (level ^d)^;^s^]: ^d line^[s^]^[ (unprocessed)^;^; (modified)^]^[; Subject: ^a^]" , subsystem_name, subsystem_version, abbrev_enabled, sdm_invocation.debug_mode, (subsystem_level ^= 1), subsystem_level, message.body.total_lines, (message.body.total_lines ^= 1), (sdm_invocation.message_state - UNPROCESSED_MESSAGE + 1), (message.subject.text_lth > 0), message_subject); return; %page; /* The "quit" request: exits send_mail unless the message has been modified since it was last sent/saved/written; in the latter case, the user is queried for permission to exit */ quit_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; request_name = ssu_$get_subsystem_and_request_name (P_sci_ptr); call ssu_$arg_count (P_sci_ptr, n_arguments); sdm_invocation.abort_code = 0; /* assume message was processed before exit */ force = "0"b; /* ask user by default */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then if (argument = "-force") | (argument = "-fc") then force = "1"b; else if (argument = "-no_force") | (argument = "-nfc") then force = "0"b; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, "^a", argument); else call ssu_$abort_line (P_sci_ptr, error_table_$bad_arg, "This request only accepts control arugments.") ; end; if sdm_invocation.message_state ^= PROCESSED_MESSAGE then do; sdm_invocation.abort_code = emf_et_$send_mail_aborted; if ^force then /* ... need the user's permission */ call command_query_$yes_no (force, 0, request_name, "", "^a^/Do you still wish to quit?", QUESTION (sdm_invocation.message_state)); if ^force then call ssu_$abort_line (P_sci_ptr, 0); end; call ssu_$abort_subsystem (P_sci_ptr, 0); /* never returns */ %page; %include sdm_invocation; %page; %include mlsys_message; end sdm_misc_requests_;  sdm_msg_requests_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 275733 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* send_mail requests which manipulate the message text and, occasionally, the header */ /* Created: January 1979 by G. Palter */ /* Modified: 27 January 1979 by G. Palter to implement -header option of qedx and apply requests, add -brief_header to print, change list to print_header, and make header printing show the entire header */ /* Modified: 1 February 1979 by G. Palter to make -header option of qedx and apply flush generated fields from text given to user */ /* Modified: 2 February 1979 by G. Palter to check line length in fill request */ /* Modified: 25 December 1979 by W. Olin Sibert to update for new emf_info structure */ /* Modified: 25 December 1979 by W. Olin Sibert to support auto_fill mode */ /* Modified: 18 September 1982 by G. Palter to implement new definition of filling in send_mail (fill => auto fill) and to add -fill/-no_fill control arguments to qedx and apply to override the default */ /* Modified: January 1983 by G. Palter to use qedx_ (yea!) */ /* Modified: September 1983 by G. Palter to obey the auto_write flag (sigh) and as part of the conversion to the new mail system interface */ /* Modified: 8 March 1984 by G. Palter to fix error #0424 -- if the "-header" option is specified for the qedx or apply requests and the message text, after editing, does not have a header, the send_mail invocation will be left without a message to process. Use of any subsequent request which must actually access the message (eg: print) will result in a null pointer fault */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_msg_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); return; /* not an entry */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl message_buffer character (4 * sys_info$max_seg_size) unaligned based (message_buffer_ptr); dcl message_text character (message_text_lth) unaligned based (message_buffer_ptr); dcl message_buffer_ptr pointer; dcl message_text_lth fixed binary (21); dcl request_line character (request_line_lth) unaligned based (request_line_ptr); dcl request_line_ptr pointer; dcl request_line_lth fixed binary (21); dcl 1 local_qi aligned, /* data structure for invoking qedx_ */ 2 header like qedx_info.header, 2 buffers (2) like qedx_info.buffers; /* ... buffers 0 and (maybe) exec */ dcl fatal_error bit (1) aligned; /* set ON by sdm_text_mgr_$fill_text when necessary */ dcl code fixed binary (35); dcl removed_reply_references bit (1) aligned; /* ON => In-Reply-To field was deleted before editing */ dcl include_header bit (1) aligned; /* ON => -header option given to request */ dcl fill bit (1) aligned; /* ON => fill the message after editing */ dcl auto_write bit (1) aligned; /* ON => enable auto-writing in qedx (sigh) */ dcl formatting_mode fixed binary; /* how much detail to be displayed in the message header */ dcl first_command_argument_idx fixed binary; /* where command line starts in the apply request */ dcl fill_width fixed binary; dcl sys_info$max_seg_size fixed binary (19) external; dcl iox_$user_output pointer external; /* format: off */ dcl (error_table_$bad_conversion, error_table_$badopt, error_table_$fatal_error, error_table_$noarg, error_table_$smallarg, mlsys_et_$message_too_large, mlsys_et_$text_parse_failed) fixed binary (35) external; /* format: on */ dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl ioa_ entry () options (variable); dcl mail_system_$add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35)); dcl mail_system_$delete_reply_reference entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$create_message entry (character (8), pointer, fixed binary (35)); dcl mail_system_$free_message entry (pointer, fixed binary (35)); dcl mail_system_$replace_body entry (pointer, pointer, fixed binary (35)); dcl mlsys_utils_$format_message entry (pointer, pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$parse_message_text entry (character (*), pointer, character (8), pointer, pointer, fixed binary (35)); dcl mlsys_utils_$print_address_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_address_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_date_time_field entry (character (*) varying, fixed binary (71), bit (1) aligned, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_body entry (pointer, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_header entry (pointer, fixed binary, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_message_id_field entry (character (*) varying, bit (72) aligned, fixed binary, pointer, fixed binary (35)); dcl mlsys_utils_$print_text_field entry (character (*) varying, character (*), bit (1) aligned, fixed binary, pointer, fixed binary (35)); dcl qedx_ entry (pointer, fixed binary (35)); dcl sdm_text_mgr_$fill_text entry (pointer, fixed binary, bit (1) aligned); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$apply_request_util entry (pointer, fixed binary, pointer, fixed binary (21), fixed binary (21)); dcl ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl cleanup condition; dcl (addr, clock, index, length, null, string, unspec) builtin; %page; /* The "print" request: prints the message text and part or all of the header */ print_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); formatting_mode = BRIEF_FORMATTING_MODE; /* default is -brief_header */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-long_header") | (argument = "-lghe") then formatting_mode = LONG_FORMATTING_MODE; else if (argument = "-header") | (argument = "-he") then formatting_mode = DEFAULT_FORMATTING_MODE; else if (argument = "-brief_header") | (argument = "-bfhe") then formatting_mode = BRIEF_FORMATTING_MODE; else if (argument = "-no_header") | (argument = "-nhe") then formatting_mode = NONE_FORMATTING_MODE; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, 0, "Usage: print {-control_args}"); end; if formatting_mode ^= NONE_FORMATTING_MODE then do; call print_message_header (); /* ... print the header/summary */ call ioa_ (""); /* ... and a blank line to separate it from the body */ end; else call ioa_ ("^/(^d line^[s^] in body):", message.body.total_lines, (message.body.total_lines ^= -1)); call mlsys_utils_$print_message_body (message_ptr, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the message body."); return; %page; /* format: off */ /* The "print_header" request: either prints the header as it will appear when transmitted or prints a short summary of the message in the following form: (N lines in text): {Subject: STR} To: addresses {cc: addresses} {bcc: addresses} where {}'s denote optional items. If no primary recipients exist, "" is printed in the To field */ /* format: on */ print_header_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); formatting_mode = DEFAULT_FORMATTING_MODE; /* default is the standard header */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-long") | (argument = "-lg") then formatting_mode = LONG_FORMATTING_MODE; else if (argument = "-default") | (argument = "-dft") then formatting_mode = DEFAULT_FORMATTING_MODE; else if (argument = "-brief") | (argument = "-bf") then formatting_mode = BRIEF_FORMATTING_MODE; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, 0, "Usage: print_header {-control_args}"); end; call print_message_header (); return; %page; /* The "qedx" request: invokes the qedx editor on the message text (or the header and text if requested) */ qedx_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); fill_width = sdm_invocation.fill_width; /* set default width */ fill = sdm_invocation.fill; /* use global fill specification */ auto_write = sdm_invocation.auto_write; /* use global auto-write specification (sigh) */ include_header = "0"b; /* defaults to not editing the header */ request_line_lth = 0; /* no -request */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control agument */ /*** ... these first two control arguments are bought to you by the MCR boards (sigh) */ if argument = "-auto_write" then auto_write = "1"b; else if argument = "-no_auto_write" then auto_write = "0"b; else if (argument = "-fill") | (argument = "-fi") then fill = "1"b; else if (argument = "-no_fill") | (argument = "-nfi") then fill = "0"b; else if (argument = "-line_length") | (argument = "-ll") then if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Number after ""-line_length""."); else do; /* user supplied fill width */ argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "", "-line_length ^a", argument); if fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else if (argument = "-header") | (argument = "-he") then include_header = "1"b; else if (argument = "-no_header") | (argument = "-nhe") then include_header = "0"b; else if (argument = "-request") | (argument = "-rq") then do; if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "String after ""-request""."); argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); request_line_ptr = addr (argument); request_line_lth = length (argument); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, 0, "Usage: qedx {-control_args}"); end; message_buffer_ptr = null (); /* for cleanup handler */ removed_reply_references = "0"b; on condition (cleanup) begin; if removed_reply_references then call restore_reply_references (); if message_buffer_ptr ^= null () then call ssu_$release_temp_segment (P_sci_ptr, message_buffer_ptr); end; call prepare_message (); /* prepare the message for editing */ local_qi.header.version = QEDX_INFO_VERSION_1; local_qi.editor_name = ssu_$get_subsystem_and_request_name (sci_ptr); string (local_qi.header.flags) = ""b; local_qi.header.query_if_modified = "1"b; /* can't exit without writing */ local_qi.n_buffers = 1; /* start with just the message buffer */ local_qi.buffers (1).buffer_name = "0"; /* it's buffer 0 (the default one) */ local_qi.buffers (1).buffer_pathname = ""; local_qi.buffers (1).region_ptr = message_buffer_ptr; local_qi.buffers (1).region_max_lth = length (message_buffer); local_qi.buffers (1).region_initial_lth = message_text_lth; string (local_qi.buffers (1).flags) = ""b; local_qi.buffers (1).read_write_region, /* ... straight into/out of our temporary segment */ local_qi.buffers (1).locked_pathname, local_qi.buffers (1).default_read_ok, local_qi.buffers (1).default_write_ok = "1"b; local_qi.buffers (1).auto_write = auto_write; /* ... sigh */ if request_line_lth > 0 then do; /* need an "exec" buffer for the requests */ local_qi.n_buffers = 2; /* ... obviously */ local_qi.buffers (2).buffer_name = "exec"; local_qi.buffers (2).buffer_pathname = ""; /* ... doesn't come from anywhere */ local_qi.buffers (2).region_ptr = request_line_ptr; local_qi.buffers (2).region_max_lth, local_qi.buffers (2).region_initial_lth = request_line_lth; string (local_qi.buffers (2).flags) = ""b; local_qi.buffers (2).read_write_region, local_qi.buffers (2).execute_buffer, local_qi.buffers (2).locked_pathname = "1"b; end; call qedx_ (addr (local_qi), code); if code = error_table_$fatal_error then /* couldn't initialize: message already printed... */ call ssu_$abort_line (P_sci_ptr, 0); message_text_lth = local_qi.buffers (1).region_final_lth; /* get length of the buffer after editing */ call update_message (); /* get the message header/body back from the user's editing */ if fill then do; /* refill it */ call sdm_text_mgr_$fill_text (sdm_invocation_ptr, fill_width, fatal_error); if fatal_error then call ssu_$abort_line (P_sci_ptr, 0); end; /* ... fill_text will print appropriate messages */ return; %page; /* The "apply" request: applies an arbitrary Multics command line to a temporary segment containing the message text (or text and header if requested) and updates the message with the contents of the segment upon completion of the command line. This request can be used to invoke editors other than qedx (eg: Emacs) on the message */ apply_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); if n_arguments = 0 then call ssu_$abort_line (P_sci_ptr, 0, "Usage: apply {-control_args} command-line"); fill_width = sdm_invocation.fill_width; /* set default width */ fill = sdm_invocation.fill; /* defaults to global fill specification */ include_header = "0"b; first_command_argument_idx = 0; /* haven't found the start of the command line yet */ do argument_idx = 1 to n_arguments /* look for control arguments ... */ while (first_command_argument_idx = 0); /* ... until the start of the command line */ call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-fill") | (argument = "-fi") then fill = "1"b; else if (argument = "-no_fill") | (argument = "-nfi") then fill = "0"b; else if (argument = "-line_length") | (argument = "-ll") then if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Number after ""-line_length""."); else do; /* user supplied fill width */ argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "", "-line_length ^a", argument); if fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else if (argument = "-header") | (argument = "-he") then include_header = "1"b; else if (argument = "-no_header") | (argument = "-nhe") then include_header = "0"b; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else first_command_argument_idx = argument_idx; end; /* command line starts here */ if first_command_argument_idx = 0 then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Multics command line."); message_buffer_ptr = null (); /* for cleanup handler */ removed_reply_references = "0"b; on condition (cleanup) begin; if removed_reply_references then call restore_reply_references (); if message_buffer_ptr ^= null () then call ssu_$release_temp_segment (P_sci_ptr, message_buffer_ptr); end; call prepare_message (); /* prepare the message for editing */ call ssu_$apply_request_util (P_sci_ptr, first_command_argument_idx, message_buffer_ptr, message_text_lth, message_text_lth); /* call ssu_ to construct and execute the command line */ call update_message (); /* get the message header/body back from the user's editing */ if fill then do; /* refill it */ call sdm_text_mgr_$fill_text (sdm_invocation_ptr, fill_width, fatal_error); if fatal_error then call ssu_$abort_line (P_sci_ptr, 0); end; return; %page; /* The "fill" request: reformats the message body text using format_document_ with fill-on and align-left modes */ fill_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (P_sci_ptr, n_arguments); fill_width = sdm_invocation.fill_width; /* set default width */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-line_length") | (argument = "-ll") then if argument_idx = n_arguments then call ssu_$abort_line (P_sci_ptr, error_table_$noarg, "Number after ""-line_length""."); else do; /* user supplied fill width */ argument_idx = argument_idx + 1; call ssu_$arg_ptr (P_sci_ptr, argument_idx, argument_ptr, argument_lth); fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, error_table_$bad_conversion, "", "-line_length ^a", argument); if fill_width < 31 then call ssu_$abort_line (P_sci_ptr, 0, "Line length must be greater than 30."); end; else call ssu_$abort_line (P_sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_line (P_sci_ptr, 0, "Usage: fill {-control_args}"); end; call sdm_text_mgr_$fill_text (sdm_invocation_ptr, fill_width, fatal_error); if fatal_error then call ssu_$abort_line (P_sci_ptr, 0); return; %page; /* Prints the message header or the message summary as described above in the description of the print_header request */ print_message_header: procedure (); call ioa_ ("^/(^d line^[s^] in body):", message.body.total_lines, (message.body.total_lines ^= 1)); if formatting_mode = BRIEF_FORMATTING_MODE then do; /* Print the message summary */ if message.subject.text_lth > 0 then do; /* ... there is a subject */ call mlsys_utils_$print_text_field (SUBJECT_FIELDNAME, message_subject, "0"b /* single-line field */, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the message subject."); end; if is_empty_list (message.to) then /* ... no primary recipients */ call ioa_ ("^a: ", TO_FIELDNAME); else do; call mlsys_utils_$print_address_list_field (TO_FIELDNAME, message.to, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the To field."); end; if ^is_empty_list (message.cc) then do; /* ... there are secondary recipients */ call mlsys_utils_$print_address_list_field (CC_FIELDNAME, message.cc, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the cc field."); end; if ^is_empty_list (message.bcc) then do; /* ... there are blind recipients */ call mlsys_utils_$print_address_list_field (BCC_FIELDNAME, message.bcc, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the bcc field."); end; end; else do; /* Print the full message header: It is necessary to supply the printed representation for the Acknowledge-To, Date, From, and Message-ID fields as they are not present in a new message; actually the From field may be present but it may also be empty. This procedure has knowledge of the internal format of message identifiers used by the mail system and may fail if said format changes; in addition, the Message-ID field will be printed out of order if there are user-defined fields in the message */ if sdm_invocation.acknowledge then do; /* acknowledgements always come to us (for now) */ call mlsys_utils_$print_address_field (ACKNOWLEDGE_TO_FIELDNAME, sdm_data_$default_from_field -> address_list.addresses (1), 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the Acknowlege-To field."); end; call mlsys_utils_$print_date_time_field (DATE_TIME_CREATED_FIELDNAME, sdm_invocation.date_time_body_modified, "1"b /* include day-of-week */, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the Date field."); if is_empty_list (message.from) then do; /* no From field present: display the default */ call mlsys_utils_$print_address_list_field (FROM_FIELDNAME, sdm_data_$default_from_field, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the From field."); end; call mlsys_utils_$print_message_header (message_ptr, formatting_mode, 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the message header."); if formatting_mode = LONG_FORMATTING_MODE then do; call mlsys_utils_$print_message_id_field (MESSAGE_ID_FIELDNAME, unspec (sdm_invocation.date_time_body_modified), 0, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Attempting to print the Message-ID field."); end; end; return; end print_message_header; %page; /* Prepares the text to be edited by qedx or apply: The text always includes the message body and, optionally, the printed representation of the message header. As the message references in the In-Reply-To field can not be converted back from their printed representations, they are deleted from the message header and are added back later (see update_message) */ prepare_message: procedure (); dcl 1 local_fmo aligned like format_message_options; dcl idx fixed binary; local_fmo.version = FORMAT_MESSAGE_OPTIONS_VERSION_1; local_fmo.line_length = -1; /* ... never need to worry */ local_fmo.include_body = "1"b; /* ... always include the body */ call ssu_$get_temp_segment (P_sci_ptr, "message-text", message_buffer_ptr); message_text_lth = 0; /* nothing in the buffer yet */ if include_header then do; /* include the message header (but not In-Reply-To) */ if message.n_reply_references > 0 then do; /* ... get rid of the In-Reply-To field */ do idx = message.n_reply_references to 1 by -1; call mail_system_$delete_reply_reference (message_ptr, idx, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Deleting the In-Reply-To field."); end; removed_reply_references = "1"b; /* ... will need to put it back later */ end; local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = DEFAULT_FORMATTING_MODE; end; else /* include only the message body */ local_fmo.envelope_formatting_mode, local_fmo.header_formatting_mode, local_fmo.redistributions_list_formatting_mode = NONE_FORMATTING_MODE; call mlsys_utils_$format_message (message_ptr, addr (local_fmo), message_buffer_ptr, length (message_buffer), message_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Preparing the message for editing."); return; end prepare_message; %page; /* Updates the message from the text returned by qedx or apply: If the user had asked to edit the header, the new header in the message (if any) will replace the old header. If the In-Reply-To field was deleted by prepare_message, above, it will be restored here */ update_message: procedure (); dcl 1 local_pto aligned like parse_text_options; dcl abort_the_line bit (1) aligned; dcl code fixed binary (35); dcl idx fixed binary; abort_the_line = "0"b; /* until proven otherwise */ if include_header then do; /* Supplied text contains a header which must be parsed */ call mail_system_$free_message (sdm_invocation.message_ptr, (0)); /* by definition: the old message is invalidated */ local_pto.version = PARSE_TEXT_OPTIONS_VERSION_1; local_pto.area_ptr = sdm_invocation.area_ptr; local_pto.list_errors, local_pto.validate_addresses, local_pto.include_invalid_addresses = "1"b; local_pto.mbz = ""b; message_ptr = null (); call mlsys_utils_$parse_message_text (message_text, addr (local_pto), MESSAGE_VERSION_2, message_ptr, parse_text_error_list_ptr, code); if message_ptr = null () then do; /* parse failed badly: treat entire text as message body */ call mail_system_$create_message (MESSAGE_VERSION_2, message_ptr, (0)); call use_text_as_message_body (); end; sdm_invocation.message_ptr = message_ptr; /* this is now the message ... */ if removed_reply_references then /* put back the In-Reply-To field ... */ call restore_reply_references (); if code ^= 0 then do; /* something went wrong ... */ abort_the_line = "1"b; if code = mlsys_et_$text_parse_failed then do; do idx = 1 to parse_text_error_list.n_errors; begin; dcl erroneous_text character (parse_text_error_list.errors (idx).text_lth) unaligned defined (message_text) position (parse_text_error_list.errors (idx).text_start); call ssu_$print_message (P_sci_ptr, parse_text_error_list.errors (idx).code, "^a^/^-^a", parse_text_error_list.errors (idx).additional_info, erroneous_text); end; end; end; else call ssu_$print_message (P_sci_ptr, code); end; end; else /* supplied text is the new message body */ call use_text_as_message_body (); /* Cleanup */ sdm_invocation.date_time_body_modified = clock ();/* for psuedo Date/Message-ID fields */ if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; call ssu_$release_temp_segment (P_sci_ptr, message_buffer_ptr); if abort_the_line then call ssu_$abort_line (P_sci_ptr, 0); return; /* Internal to update_message: inserts the supplied text as the message body */ use_text_as_message_body: procedure (); dcl 1 local_mbsp aligned like message_body_section_parameter; dcl code fixed binary (35); local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; local_mbsp.section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_body_section_ptr = addr (local_mbsp.section); message_preformatted_body_section.text_ptr = message_buffer_ptr; message_preformatted_body_section.text_lth = message_text_lth; call mail_system_$replace_body (message_ptr, addr (local_mbsp), code); if code ^= 0 then call ssu_$abort_line (sdm_invocation.sci_ptr, code, "Attempting to place the edited message text into the message."); return; end use_text_as_message_body; end update_message; %page; /* Actually restores the references to the original messages to the In-Reply-To field */ restore_reply_references: procedure (); dcl idx fixed binary; removed_reply_references = "0"b; /* only try this once */ original_messages_ptr = sdm_invocation.original_messages_ptr; if original_messages_ptr = null () then return; /* there are no reply references(?) */ do idx = 1 to original_messages.n_original_messages; call mail_system_$add_reply_reference (sdm_invocation.message_ptr, original_messages.messages (idx).message_ptr, (-1), code); if code ^= 0 then call ssu_$print_message (P_sci_ptr, code, "Unable to add the reference to message #^d to the In-Reply-To field.", original_messages.messages (idx).message_idx); end; return; end restore_reply_references; %page; /* Determines if the given address list is empty */ is_empty_list: procedure (p_address_list_ptr) returns (bit (1) aligned); dcl p_address_list_ptr pointer parameter; if p_address_list_ptr = null () then /* if there's no data at all, it's empty */ return ("1"b); else return ((p_address_list_ptr -> address_list.n_addresses = 0)); end is_empty_list; %page; %include sdm_invocation; %page; %include sdm_original_messages; %page; %include sdm_data; %page; %include send_mail_options; %page; %include mlsys_message; %page; %include mlsys_address_list; %page; %include mlsys_field_names; %page; %include mlsys_format_options; %page; %include mlsys_parse_txt_options; %page; %include qedx_info; end sdm_msg_requests_;  sdm_original_requests_.pl1 10/02/89 0908.5rew 10/02/89 0816.0 86085 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-13,Lee), approve(89-05-10,MCR8104), audit(89-07-18,LZimmerman), install(89-10-02,MR12.3-1079): phx21011, phx20089, phx18851, phx13551 (Mail 401) - fixed incorrect sci_ptr used by in_reply_to_request; reformatting. END HISTORY COMMENTS */ /* format: off */ /* send_mail requests which are valid only within invocations created by the read_mail reply request. These requests are: in_reply_to -- displays/modifies the list of reply references for this message */ /* Created: October 1983 by G. Palter */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_original_requests_: procedure (P_sci_ptr, P_sdm_invocation_ptr); return; /* not an entrypoint */ /* Parameters */ dcl P_sci_ptr pointer parameter; dcl P_sdm_invocation_ptr pointer parameter; /* Local copies of parameters */ dcl sci_ptr pointer; /* Remaining declarations */ dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl message_specifier_idxs (n_message_specifiers_allocated) fixed binary based (message_specifier_idxs_ptr); dcl message_specifier_idxs_ptr pointer; dcl (n_message_specifiers_allocated, n_message_specifiers) fixed binary; dcl message_type fixed binary; /* type of messages to select (all/undeleted/deleted) */ dcl saved_rdm_sci_ptr pointer; /* used to prevent errors from aborting the reply request */ dcl reset_to_reply_messages bit (1) aligned; /* ON => reset reply references to their original value */ dcl (message_idx, message_number, idx) fixed binary; dcl original_message_ptr pointer; dcl code fixed binary (35); dcl iox_$user_output pointer external; dcl error_table_$badopt fixed binary (35) external; dcl error_table_$inconsistent fixed binary (35) external; dcl cu_$grow_stack_frame entry (fixed binary (19), pointer, fixed binary (35)); dcl ioa_ entry () options (variable); dcl mail_system_$add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35)); dcl mail_system_$delete_reply_reference entry (pointer, fixed binary, fixed binary (35)); dcl mlsys_utils_$print_references_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_mailbox_interface_$read_message entry (pointer, fixed binary, pointer, fixed binary (35)); dcl rdm_message_mark_mgr_$clear_marked_messages entry (pointer); dcl rdm_message_mark_mgr_$mark_messages entry (pointer, pointer, fixed binary (21), fixed binary, bit (*), fixed binary (35)); dcl rdm_message_mark_mgr_$remark_original_messages entry (pointer); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl cleanup condition; dcl (index, size) builtin; %page; /* The "in_reply_to" request: displays or modifies the In-Reply-To field. The In-Reply-To field contains the list of original messages for which the message being created by this send_mail invocation is a reply */ in_reply_to_request: entry (P_sci_ptr, P_sdm_invocation_ptr); sci_ptr = P_sci_ptr; sdm_invocation_ptr = P_sdm_invocation_ptr; message_ptr = sdm_invocation.message_ptr; call ssu_$arg_count (sci_ptr, n_arguments); if n_arguments = 0 then do; /* No arguments given -- print the current value of the In-Reply-To field */ if message.n_reply_references = 0 then call ioa_ ("^a: ", REPLY_REFERENCES_FIELDNAME); else do; call mlsys_utils_$print_references_list_field (REPLY_REFERENCES_FIELDNAME, message.reply_references, 0 /* use the terminal's line-length */, iox_$user_output, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Displaying the ^a field.", REPLY_REFERENCES_FIELDNAME); end; end; else do; /* Arguments given -- change the In-Reply-To field to reference only those messages identified by the given message specifiers; the control argument "-default" may be used to restore the field to the original list supplied by the read_mail reply request */ rdm_invocation_ptr = sdm_invocation.rdm_invocation_ptr; saved_rdm_sci_ptr = rdm_invocation.sci_ptr; /* for cleanup handler ... */ on condition (cleanup) begin; rdm_invocation.sci_ptr = saved_rdm_sci_ptr; end; /* phx20089 RL - control action taken by aborts when rdm_invocation.sci_ptr is used; */ /* prevent aborts beyond current invocation */ rdm_invocation.sci_ptr = P_sci_ptr; n_message_specifiers_allocated = n_arguments;/* can't have more message specifiers than arguments */ call cu_$grow_stack_frame (size (message_specifier_idxs), message_specifier_idxs_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, 0, "Too many message specifiers on the request line."); n_message_specifiers = 0; call rdm_message_mark_mgr_$clear_marked_messages (rdm_invocation_ptr); /*** Argument processing */ message_type = NON_DELETED_MESSAGES; /* defaults to "-only_non_deleted" */ reset_to_reply_messages = "0"b; /* "-default" not seen */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-default") | (argument = "-dft") then reset_to_reply_messages = "1"b; else if (argument = "-no_default") | (argument = "-ndft") then reset_to_reply_messages = "0"b; else if (argument = "-include_deleted") | (argument = "-idl") then message_type = ALL_MESSAGES; else if (argument = "-only_deleted") | (argument = "-odl") then message_type = ONLY_DELETED_MESSAGES; else if (argument = "-only_non_deleted") | (argument = "-ondl") then message_type = NON_DELETED_MESSAGES; else call ssu_$abort_line (sci_ptr, error_table_$badopt, """^a""", argument); else do; /* a mesage specifier */ n_message_specifiers = n_message_specifiers + 1; message_specifier_idxs (n_message_specifiers) = argument_idx; end; end; if (n_message_specifiers > 0) & reset_to_reply_messages then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, """-default"" and message specifiers."); /*** Mark the appropriate messages */ if reset_to_reply_messages then /* restore the In-Reply-To field to its initial value */ call rdm_message_mark_mgr_$remark_original_messages (rdm_invocation_ptr); else do; /* use the given message specifiers */ do idx = 1 to n_message_specifiers; call ssu_$arg_ptr (sci_ptr, message_specifier_idxs (idx), argument_ptr, argument_lth); call rdm_message_mark_mgr_$mark_messages (rdm_invocation_ptr, argument_ptr, argument_lth, message_type, ""b, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code); end; end; /*** Construct the new list of original messages */ original_messages_n_original_messages = marked_chain.n_messages; allocate original_messages in (sdm_area) set (original_messages_ptr); original_messages.version = ORIGINAL_MESSAGES_VERSION_1; do message_idx = 1 to marked_chain.n_messages; message_number = marked_chain.messages (message_idx); call rdm_mailbox_interface_$read_message (rdm_invocation_ptr, message_number, original_message_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Reading message #^d from ^a.", message_number, rdm_invocation.mailbox_name); original_messages.messages (message_idx).message_ptr = original_message_ptr; original_messages.messages (message_idx).message_idx = message_number; end; /*** Delete the old In-Reply-To field */ do idx = message.n_reply_references to 1 by -1; call mail_system_$delete_reply_reference (message_ptr, idx, code); if code ^= 0 then call ssu_$abort_line (P_sci_ptr, code, "Deleting the ^a field.", REPLY_REFERENCES_FIELDNAME); end; /*** Build the new In-Reply-To field */ sdm_invocation.original_messages_ptr = original_messages_ptr; do idx = 1 to original_messages.n_original_messages; call mail_system_$add_reply_reference (message_ptr, original_messages.messages (idx).message_ptr, (-1), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Adding message #^d to the new message's ^a field.", message_number, REPLY_REFERENCES_FIELDNAME); end; if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; rdm_invocation.sci_ptr = saved_rdm_sci_ptr; end; return; %page; %include sdm_invocation; %page; %include sdm_original_messages; %page; %include rdm_invocation; %page; %include rdm_message_list; %page; %include rdm_message_chains; %page; %include mlsys_message; %page; %include mlsys_field_names; end sdm_original_requests_;  sdm_request_tables_.alm 11/05/86 1552.0r w 11/04/86 1038.6 61398 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Request definitions for the Multics send_mail subsystem " Created: 1 January 1979 by G. Palter " Modified: 23 January 1979 by G. Palter to add 'rm' as synonym of 'remove' " Modified: 26 January 1979 by G. Palter to rename 'list' to 'print_header' " Modified: 26 April 1980 by G. Palter to add 'do' request " Modified: 28 April 1980 by G. Palter to use new_ssu_ entries for version 4.1 subsystem utilities " Modified: 10 May 1980 by W. Olin Sibert to use ssu_v1_macros and to call ssu_requests_ " for subsystem standard requests " Modified: 14 May 1980 by W. Olin Sibert to rearrange requests and add 'list_help' " Modified: 1 June 1980 by G. Palter to implement suggestion #0186 -- there should be a " 'print_original' request in send_mail which prints the message being replied to when " invoked by read_mail's 'reply' request. (Also added 'print_orig_header', " 'list_original' and 'write_original') " Modified: 10 June 1980 by G. Palter to add 'log_original' and 'save_original' " Modified: 27 March 1981 by G. Palter to put the 'original' requests into a separate table " Modified: 17 December 1981 by G. Palter to rearrange requests, use new definition of '?', " and add 'list_requests' " Modified: 16 February 1982 by G. Palter to use new macros, rename 'print_orig_header' to " 'print_original_header' (retaining the old name), and add 'exec_com', 'answer', " 'abbrev', 'if', 'ready', 'ready_on', and 'ready_off' " Modified: 25 February 1982 by G. Palter to add 'subsystem_name' and 'subsystem_version' " Modified: 28 February 1982 by G. Palter for dont_summarize and dont_list flags " Modified: 17 September 1982 by G. Palter to rename to sdm_request_tables_, add the " debug_requests table, and delete standard subsystem requests from the tables " Modified: 23 September 1982 by G. Palter to add appropriate short names to the 'append' " and 'preface' requests for compatibility with read_mail " Modified: September 1983 by G. Palter to add 'bcc', make 'in_reply_to' an original " request, eliminate 'ssu_debug' as debug mode now enables ssu_ debugging include ssu_request_macros name sdm_request_tables_ " " Standard send_mail requests begin_table standard_requests request ., sdm_misc_requests_$self_identify, (), (Print current status.) request quit, sdm_misc_requests_$quit_request, (q), (Leave send_mail.) request send, sdm_mbx_requests_$send_request, (), (Send the message.) request print, sdm_msg_requests_$print_request, (pr,p), (Print the message.) request print_header, sdm_msg_requests_$print_header_request, (prhe), (Print the message's header.) request qedx, sdm_msg_requests_$qedx_request, (qx), (Edit the message.) request fill, sdm_msg_requests_$fill_request, (fi), (Reformat text of the message to fit in given width.) request write, sdm_file_requests_$write_request, (w), (Write the message, unformatted, to an ASCII segment.) request to, sdm_header_requests_$to_request, (), (Print/modify the primary recipients of the message.) request cc, sdm_header_requests_$cc_request, (), (Print/modify the secondary recipients of the message.) request bcc, sdm_header_requests_$bcc_request, (), (Print/modify the list of "blind" recipients of the message.) request remove, sdm_header_requests_$remove_request, (rm), (Remove recipients, authors, or the subject of the message.) request subject, sdm_header_requests_$subject_request, (sj), (Print/modify the subject of the message.), flags.allow_both request from, sdm_header_requests_$from_request, (), (Print/modify the authors of the message.) request reply_to, sdm_header_requests_$reply_to_request, (rpt), (Print/modify the recipients of replies to the message.) request message_id, sdm_header_requests_$message_id_request, (mid), (Print the unique identifier of the message.) request apply, sdm_msg_requests_$apply_request, (ap), (Apply a Multics command line to the message.) request log, sdm_mbx_requests_$log_request, (), (Add the message to your logbox.) request save, sdm_mbx_requests_$save_request, (sv), (Add the message to the given savebox.) request copy, sdm_mbx_requests_$copy_request, (cp), (Add the message to the given mailbox.) request append, sdm_file_requests_$append_request, (app), (Write the message at the end of an ASCII segment.) request preface, sdm_file_requests_$preface_request, (prf), (Write the message at the beginning of an ASCII segment.) request debug_mode, sdm_debug_requests_$debug_mode, (), (Enable/disable send_mail debugging facilities.), flags.allow_command+flags.dont_summarize+flags.dont_list end_table standard_requests " " Requests used to access the message(s) being answered by this send_mail begin_table original_requests request in_reply_to, sdm_original_requests_$in_reply_to_request, (irt), (Print/modify the list of message(s) being answered by this send_mail.) request print_original, rdm_msg_requests_$print_request, (pro), (Prints the message(s) being answered by this send_mail.) request print_original_header, rdm_msg_requests_$print_header_request, (prohe), (Prints the headers of the message(s) being answered by this send_mail.) request list_original, rdm_msg_requests_$list_request, (lso), (Summarizes the message(s) being answered by this send_mail.), flags.allow_both request log_original, rdm_mbx_requests_$log_request, (logo), (Adds the message(s) being answered by this send_mail to your logbox.) request save_original, rdm_mbx_requests_$save_request, (svo), (Adds the message(s) being answered by this send_mail to the specified savebox.) request write_original, rdm_file_requests_$write_request, (wo), (Write the message(s) being answered to an ASCII segment.) end_table original_requests " " Requests used for debugging send_mail begin_table debug_requests request probe, sdm_debug_requests_$probe, (pb), (Invokes the probe debugger with all available data structures.), flags.allow_command+flags.dont_summarize+flags.dont_list end_table debug_requests end  sdm_set_info_directories_.pl1 10/27/83 1616.3rew 10/27/83 1442.3 17064 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* Sets the info directories list used by the send_mail subsystem */ /* Created: 3 October 1982 by G. Palter */ /* Modified: August 1983 by G. Palter to convert to new mail system interface */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ sdm_set_info_directories_: procedure (P_sdm_invocation_ptr, P_code); /* Parameters */ dcl P_sdm_invocation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; /* send_mail info directories */ dcl 1 sdm_info_dirs aligned, 2 header like info_dirs_list.header, 2 dirs (2) like info_dirs_list.info_dirs; /* see below */ /* Remaining declarations */ dcl sdm_data_$info_directory character (168) external; dcl ssu_$set_info_dirs entry (pointer, pointer, fixed binary (35)); dcl (addr, null, rtrim) builtin; %page; /* sdm_set_info_directories_: entry (P_sdm_invocation_ptr, P_code); */ sdm_invocation_ptr = P_sdm_invocation_ptr; sdm_info_dirs.version = INFO_DIRS_LIST_VERSION_1; sdm_info_dirs.dirs (1).info_dirname = sdm_data_$info_directory; sdm_info_dirs.n_info_dirs = 1; /* always include standard info files */ if sdm_invocation.rdm_invocation_ptr ^= null () then do; sdm_info_dirs.dirs (2).info_dirname = rtrim (sdm_data_$info_directory) || ">original_requests"; sdm_info_dirs.n_info_dirs = 2; /* include original requests info files */ end; call ssu_$set_info_dirs (sdm_invocation.sci_ptr, addr (sdm_info_dirs), P_code); return; %page; %include sdm_invocation; %page; %include ssu_info_dirs_list; end sdm_set_info_directories_;  sdm_set_request_tables_.pl1 10/27/83 1616.3rew 10/27/83 1442.4 23598 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: off */ /* Sets the request table list used by the send_mail subsystem */ /* Created: 17 September 1982 by G. Palter */ /* Modified: August 1983 by G. Palter to convert to new mail system interface */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ sdm_set_request_tables_: procedure (P_sdm_invocation_ptr, P_code); /* Parameters */ dcl P_sdm_invocation_ptr pointer parameter; dcl P_code fixed binary (35) parameter; /* send_mail request tables */ dcl 1 sdm_request_tables aligned, 2 header like request_tables_list.header, 2 tables (4) like request_tables_list.tables; /* up to 4 possible tables (see below) */ /* Remaining declarations */ dcl table_idx fixed binary; /* format: off */ dcl (sdm_request_tables_$standard_requests, sdm_request_tables_$original_requests, sdm_request_tables_$debug_requests, ssu_request_tables_$standard_requests) bit (36) aligned external; /* format: on */ dcl ssu_$set_request_tables entry (pointer, pointer, fixed binary (35)); dcl (addr, null) builtin; %page; /* sdm_set_request_tables_: entry (P_sdm_invocation_ptr, P_code); */ sdm_invocation_ptr = P_sdm_invocation_ptr; sdm_request_tables.version = REQUEST_TABLES_LIST_VERSION_1; table_idx = 1; /* always include standard send_mail requests */ sdm_request_tables.tables (1).table_ptr = addr (sdm_request_tables_$standard_requests); if sdm_invocation.rdm_invocation_ptr ^= null () then do; table_idx = table_idx + 1; /* include the original requests if in read_mail reply */ sdm_request_tables.tables (table_idx).table_ptr = addr (sdm_request_tables_$original_requests); end; if sdm_invocation.debug_mode then do; /* include debugging requests if needed */ table_idx = table_idx + 1; sdm_request_tables.tables (table_idx).table_ptr = addr (sdm_request_tables_$debug_requests); end; table_idx = table_idx + 1; /* standard subsystem requests are always last */ sdm_request_tables.tables (table_idx).table_ptr = addr (ssu_request_tables_$standard_requests); sdm_request_tables.n_tables = table_idx; call ssu_$set_request_tables (sdm_invocation.sci_ptr, addr (sdm_request_tables), P_code); return; %page; %include sdm_invocation; %page; %include ssu_request_tables_list; end sdm_set_request_tables_;  sdm_subsystem_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 246339 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* The Multics send_mail subsystem */ /* Created: December 1978 by G. Palter */ /* Modified: 11 January 1979 by G. Palter to print informative error messages and only print sdm_data_$special_message once per process */ /* Modified: 15 January 1979 by G. Palter to support no abort feature */ /* Modified: 24 January 1979 by G. Palter to support original text feature for use by read_mail "reply" request */ /* Modified: 31 January 1979 by G. Palter to revert to filling before invoking qedx */ /* Modified: 7 February 1979 by G. Palter to correct bug with -fill and using \f in input mode */ /* Modified: 25 December 1979 by W. Olin Sibert to implement auto_fill mode */ /* Modified: 25 April 1980 by G. Palter to implement abbrev processing */ /* Modified: 28 April 1980 by G. Palter to call v1_ssu_ entries for version 4.1 subsystems */ /* Modified: 5 May 1980 by W. Olin Sibert to use new ssu_ interfaces */ /* Modified: 1 June 1980 by G. Palter to implement suggestion #0186 -- there should be a "print_original" request in send_mail which prints the message being replied to when invoked by read_mail's "reply" request */ /* Modified: 4 June 1980 by G. Palter to implement suggestion #0287 -- if a reply is being created and the user exits send_mail without sending the reply, the "-delete" control argument of the "reply" request should be ignored */ /* Modified: 27 January 1981 by G. Palter to fix bug #0354 -- both read_mail and send_mail mis-declare ssu_$set_prompt: for read_mail, the declaration used works; for send_mail, use of -no_prompt can cause severe problems (faults, fatal process errors, etc.) */ /* Modified: 27 March 1981 by G. Palter to put the "original" requests into a separate request table */ /* Modified: 16 February 1982 by G. Palter for version 4 sdm_subsystem_info (default profiles) and new calling sequences for ssu_$create_invocation and ssu_$set_abbrev_info */ /* Modified: 2 March 1982 by G. Palter to eliminate a window which prevented subsystem invocations from being destroyed */ /* Modified: 17 September 1982 by G. Palter to implement new defaults for -fill and -request_loop based on terminal/file input, change filling to occur after the initial invocation of qedx, support debug_mode and new prompt control, and set the exec_com search list and suffix properly */ /* Modified: 3 October 1982 by G. Palter to use sdm_set_info_directories_ */ /* Modified: September 1983 by G. Palter as part of the conversion of send_mail to the new mail system interface */ /* Modified: April 1984 by G. Palter to fix error #0438 -- the primitives which allow a user to replace the address list portions of a message (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's copy of the address list read-only. Instead, they should copy the user's list to allow the user to continue to modify the list if desired for later additional use */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_subsystem_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_sdm_invocation_ptr pointer parameter; /* -> description of send_mail subsystem */ dcl P_sdm_subsystem_info_ptr pointer parameter; /* -> options used to create/control the subsystem */ dcl P_sdm_subsystem_info_version character (8) parameter; /* version of above structure desired by the caller */ dcl P_code fixed binary (35) parameter; /* Local copies of parameters */ dcl code fixed binary (35); /* Remaining declarations */ dcl sci_ptr pointer; dcl initial_rql character (initial_rql_lth) varying based (initial_rql_ptr); dcl initial_rql_lth fixed binary (21); dcl initial_rql_ptr pointer; dcl edit_requests character (edit_requests_lth) unaligned based (edit_requests_ptr); dcl edit_requests_lth fixed binary (21); dcl edit_requests_ptr pointer; dcl user_initial_requests character (sdm_subsystem_info.initial_requests_lth) unaligned based (sdm_subsystem_info.initial_requests_ptr); dcl sdm_subsystem_info_subject character (sdm_subsystem_info.subject_lth) unaligned based (sdm_subsystem_info.subject_ptr); dcl subsystem_area area aligned based (subsystem_area_ptr); dcl subsystem_area_ptr pointer; dcl 1 local_ai aligned like area_info; dcl subject_line character (1024); dcl subject_segment_ptr pointer; dcl (subject_lth, rest_of_subject_lth) fixed binary (21); dcl enter_request_loop bit (1) aligned; /* ON => user wants to entry the request loop */ dcl fatal_error bit (1) aligned; dcl input_terminator_type fixed binary; /* specifies how user ended message */ dcl (address_type, idx) fixed binary; dcl SEND_MAIL character (32) static options (constant) initial ("send_mail"); dcl sys_info$max_seg_size fixed binary (19) external; dcl iox_$error_output pointer external; dcl iox_$user_input pointer external; /* format: off */ dcl (error_table_$fatal_error, error_table_$long_record, error_table_$unimplemented_version, ssu_et_$subsystem_aborted) fixed binary (35) external static; /* format: on */ dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$cl entry (bit (36) aligned); dcl cu_$generate_call entry (entry, pointer); dcl cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35)); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$nnl entry () options (variable); dcl iox_$get_line entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mail_system_$add_address entry (pointer, pointer, character (8), fixed binary (35)); dcl mail_system_$add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35)); dcl mail_system_$create_address_list entry (character (8), pointer, fixed binary (35)); dcl mail_system_$create_message entry (character (8), pointer, fixed binary (35)); dcl mail_system_$free_address_list entry (pointer, fixed binary (35)); dcl mail_system_$free_message entry (pointer, fixed binary (35)); dcl mail_system_$get_address_type entry (pointer, fixed binary, fixed binary (35)); dcl mail_system_$replace_bcc entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_cc entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_from entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_reply_to entry (pointer, pointer, fixed binary (35)); dcl mail_system_$replace_subject entry (pointer, character (*), fixed binary (35)); dcl mail_system_$replace_to entry (pointer, pointer, fixed binary (35)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl sdm_set_info_directories_ entry (pointer, fixed binary (35)); dcl sdm_set_request_tables_ entry (pointer, fixed binary (35)); dcl sdm_text_mgr_$file_input entry (pointer, character (*), character (*), bit (1) aligned); dcl sdm_text_mgr_$process_original_text entry (pointer, pointer, bit (1) aligned); dcl sdm_text_mgr_$terminal_input entry (pointer, fixed binary, pointer, fixed binary (21), bit (1) aligned); dcl ssu_$create_invocation entry (character (*), character (*), pointer, pointer, character (*), pointer, fixed binary (35)); dcl ssu_$destroy_invocation entry (pointer); dcl ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35)); dcl ssu_$get_area entry (pointer, pointer, character (*), pointer); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$listen entry (pointer, pointer, fixed binary (35)); dcl ssu_$print_blast entry (pointer, pointer, fixed binary, character (*) varying, fixed binary (35)); dcl ssu_$print_message entry () options (variable); dcl ssu_$record_usage entry (pointer, pointer, fixed binary (35)); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl ssu_$set_abbrev_info entry (pointer, pointer, pointer, bit (1) aligned); dcl ssu_$set_debug_mode entry (pointer, bit (1) aligned); dcl ssu_$set_ec_search_list entry (pointer, character (32)); dcl ssu_$set_ec_suffix entry (pointer, character (32)); dcl ssu_$set_info_ptr entry (pointer, pointer); dcl ssu_$set_prompt entry (pointer, character (64) varying); dcl ssu_$set_prompt_mode entry (pointer, bit (*)); dcl cleanup condition; dcl (addcharno, addr, addwordno, clock, codeptr, divide, length, null, unspec) builtin; %page; /* Initialize an invocation of the send_mail subsystem: creates a subsystem invocation, initializes an sdm_invocation structure, and creates an sdm_subsystem_info structure containing default values as obtained from sdm_data_ */ create_invocation: entry (P_sdm_subsystem_info_version, P_sdm_invocation_ptr, P_sdm_subsystem_info_ptr, P_code); if P_sdm_subsystem_info_version ^= SDM_SUBSYSTEM_INFO_VERSION_6 then do; P_code = error_table_$unimplemented_version; /* only have one supported version */ return; end; /* Create the subsystem invocation and an area for use by the subsystem */ sci_ptr, /* for cleanup handler */ sdm_invocation_ptr, sdm_subsystem_info_ptr = null (); on condition (cleanup) begin; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); end; call ssu_$create_invocation (SEND_MAIL, (sdm_data_$version), null (), null (), "", sci_ptr, P_code); if P_code ^= 0 then return; /* failed */ unspec (local_ai) = ""b; local_ai.version = area_info_version_1; local_ai.zero_on_alloc, local_ai.extend = "1"b; call ssu_$get_area (sci_ptr, addr (local_ai), "", subsystem_area_ptr); /* Create the send_mail invocation structure */ allocate sdm_invocation in (subsystem_area) set (sdm_invocation_ptr); sdm_invocation.type = SDM_INVOCATION; sdm_invocation.sci_ptr = sci_ptr; sdm_invocation.area_ptr = subsystem_area_ptr; /* use the above area for all allocations */ sdm_invocation.message_ptr = null (); /* no message yet */ sdm_invocation.original_messages_ptr = null (); /* avoids problems with premature terminations */ call ssu_$set_info_ptr (sci_ptr, sdm_invocation_ptr); /* Create and initialize the sdm_subsystem_info structure */ allocate sdm_subsystem_info in (sdm_area) set (sdm_subsystem_info_ptr); sdm_subsystem_info.version = SDM_SUBSYSTEM_INFO_VERSION_6; sdm_subsystem_info.input_type = TERMINAL_INPUT; /* defaults to read from the terminal */ sdm_subsystem_info.address_lists = null (); /* no sources or destinations yet */ sdm_subsystem_info.subject_given = "0"b; /* no subject supplied yet */ sdm_subsystem_info.options = sdm_data_$default_options; /* set up permanent options */ sdm_subsystem_info.initial_requests_lth = 0; /* no initial request line */ sdm_subsystem_info.rdm_invocation_ptr = null (); /* don't yet know whether it was created by read_mail reply */ sdm_subsystem_info.original_messages_ptr = null (); /* no list of original messages for an In-Reply-To field */ P_sdm_invocation_ptr = sdm_invocation_ptr; P_sdm_subsystem_info_ptr = sdm_subsystem_info_ptr; P_code = 0; return; %page; /* Main workhorse of the subsystem: reads the input message and either sends the message or enters the request loop */ subsystem: entry (P_sdm_invocation_ptr, P_sdm_subsystem_info_ptr, P_code); sdm_invocation_ptr = P_sdm_invocation_ptr; sdm_subsystem_info_ptr = P_sdm_subsystem_info_ptr; if sdm_subsystem_info.version ^= SDM_SUBSYSTEM_INFO_VERSION_6 then do; P_code = error_table_$unimplemented_version; return; /* bad version: caller will cleanup */ end; sdm_invocation.debug_mode = sdm_subsystem_info.debug; call ssu_$set_debug_mode (sdm_invocation.sci_ptr, (sdm_invocation.debug_mode)); /* Create the message and place the supplied address lists (From/Reply-To/To/cc/bcc fields) into the message */ call mail_system_$create_message (MESSAGE_VERSION_2, sdm_invocation.message_ptr, code); if code ^= 0 then /* someone changed the mail system out from under us? */ call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to create the message."); sdm_invocation.message_state = UNPROCESSED_MESSAGE; sdm_invocation.date_time_body_modified = clock ();/* we need some value here */ if sdm_subsystem_info.from ^= null () then do; /* explicit authors */ call mail_system_$replace_from (sdm_invocation.message_ptr, sdm_subsystem_info.from, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the From field."); end; if sdm_data_$default_from_field = null () then do;/* create a default From field for use with "print -header" */ call mail_system_$create_address_list (ADDRESS_LIST_VERSION_2, sdm_data_$default_from_field, code); if code ^= 0 then UNABLE_TO_CREATE_DEFAULT_FROM_FIELD: call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to create the default From field."); call mail_system_$get_address_type (mlsys_data_$user_mail_table_address, address_type, (0)); if address_type = INVALID_ADDRESS then /* ... anonymous user */ call mail_system_$add_address (sdm_data_$default_from_field, mlsys_data_$user_default_mailbox_address, ADDRESS_LIST_VERSION_2, code); else call mail_system_$add_address (sdm_data_$default_from_field, mlsys_data_$user_mail_table_address, ADDRESS_LIST_VERSION_2, code); if code ^= 0 then go to UNABLE_TO_CREATE_DEFAULT_FROM_FIELD; end; if sdm_subsystem_info.reply_to ^= null () then do; call mail_system_$replace_reply_to (sdm_invocation.message_ptr, sdm_subsystem_info.reply_to, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the Reply-to field."); end; if sdm_subsystem_info.to ^= null () then do; call mail_system_$replace_to (sdm_invocation.message_ptr, sdm_subsystem_info.to, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the To field."); end; if sdm_subsystem_info.cc ^= null () then do; call mail_system_$replace_cc (sdm_invocation.message_ptr, sdm_subsystem_info.cc, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the cc field."); end; if sdm_subsystem_info.bcc ^= null () then do; call mail_system_$replace_bcc (sdm_invocation.message_ptr, sdm_subsystem_info.bcc, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the bcc field."); end; /* Process the list of original messages for which this message is a reply */ if sdm_subsystem_info.original_messages_ptr ^= null () then do; if sdm_subsystem_info.original_messages_ptr -> original_messages.version ^= ORIGINAL_MESSAGES_VERSION_1 then call abort_subsystem (sdm_invocation.sci_ptr, error_table_$unimplemented_version, "Attempting to process the list of original messages."); original_messages_n_original_messages = /* ... need our own copy: remaining code always frees it */ sdm_subsystem_info.original_messages_ptr -> original_messages.n_original_messages; allocate original_messages in (sdm_area) set (sdm_invocation.original_messages_ptr); sdm_invocation.original_messages_ptr -> original_messages = sdm_subsystem_info.original_messages_ptr -> original_messages; /*** Now add the original messages to the new message's reply references list */ original_messages_ptr = sdm_invocation.original_messages_ptr; do idx = 1 to original_messages.n_original_messages; call mail_system_$add_reply_reference (sdm_invocation.message_ptr, original_messages.messages (idx).message_ptr, (-1), code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to add a reference to message #^d to the In-Reply-To field.", original_messages.messages (idx).message_idx); end; end; /* Print the initial greeting message before possibly asking for a subject */ if sdm_data_$first_invocation then call ssu_$print_blast (sdm_invocation.sci_ptr, codeptr (subsystem), 3, sdm_data_$special_message, (0)); else call ssu_$record_usage (sdm_invocation.sci_ptr, codeptr (subsystem), (0)); sdm_data_$first_invocation = "0"b; /* Set the message subject: If requested, prompt the user for the subject and read it from the terminal */ if sdm_subsystem_info.subject_given then /* user gave a subject on the command line ... */ if sdm_subsystem_info.subject_lth ^= 0 then do; call mail_system_$replace_subject (sdm_invocation.message_ptr, sdm_subsystem_info_subject, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the Subject field."); end; else ; /* user explicitly requested no subject on the command line */ else do; /* no explicit instructions: ask for a subject */ call ioa_$nnl ("Subject: "); call iox_$get_line (iox_$user_input, addr (subject_line), length (subject_line), subject_lth, code); if code = 0 then do; /* ... got it in our automatic buffer */ begin; dcl the_subject character (subject_lth - 1) unaligned defined (subject_line) position (1); if length (the_subject) > 0 then call mail_system_$replace_subject (sdm_invocation.message_ptr, the_subject, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the Subject field."); end; end; else if code = error_table_$long_record then do; /*** ... too large for our automatic buffer: read the rest into a temporary segment */ call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "subject-buffer", subject_segment_ptr); begin; dcl subject_in_segment character (subject_lth) unaligned based (subject_segment_ptr); dcl the_subject_so_far character (subject_lth) unaligned defined (subject_line) position (1); subject_in_segment = the_subject_so_far; end; call iox_$get_line (iox_$user_input, addcharno (subject_segment_ptr, subject_lth), ((4 * sys_info$max_seg_size) - subject_lth), rest_of_subject_lth, code); if code ^= 0 then do; /* ... quite fatal */ call ssu_$release_temp_segment (sdm_invocation.sci_ptr, subject_segment_ptr); call abort_subsystem (sdm_invocation.sci_ptr, code, "Reading the message subject."); end; begin; dcl the_subject character (subject_lth + rest_of_subject_lth - 1) unaligned based (subject_segment_ptr); if length (the_subject) > 0 then call mail_system_$replace_subject (sdm_invocation.message_ptr, the_subject, code); end; /* ... code is already zero if above call isn't made */ call ssu_$release_temp_segment (sdm_invocation.sci_ptr, subject_segment_ptr); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Unable to replace the Subject field."); end; else call abort_subsystem (sdm_invocation.sci_ptr, code, "Reading the message subject."); end; /* Process remaining input options except input source and intial request line */ sdm_invocation.fill_width = sdm_subsystem_info.fill_width; sdm_invocation.brief = sdm_subsystem_info.brief; sdm_invocation.acknowledge = sdm_subsystem_info.acknowledge; sdm_invocation.notify = sdm_subsystem_info.notify; sdm_invocation.auto_write = sdm_subsystem_info.auto_write; if sdm_subsystem_info.fill_control = DEFAULT_FILL then sdm_invocation.fill = (sdm_subsystem_info.input_type = TERMINAL_INPUT); else sdm_invocation.fill = (sdm_subsystem_info.fill_control = FILL); if sdm_subsystem_info.request_loop_control = DEFAULT_REQUEST_LOOP then enter_request_loop = (sdm_subsystem_info.input_type = FILE_INPUT); else enter_request_loop = (sdm_subsystem_info.request_loop_control = REQUEST_LOOP); if sdm_subsystem_info.prompt_control.prompt_control = DEFAULT_PROMPT then ; /* use the default prompt */ else if sdm_subsystem_info.prompt_control.prompt_control = NO_PROMPT then call ssu_$set_prompt_mode (sdm_invocation.sci_ptr, DONT_PROMPT); else call ssu_$set_prompt (sdm_invocation.sci_ptr, sdm_subsystem_info.prompt_string); call ssu_$set_abbrev_info (sdm_invocation.sci_ptr, sdm_subsystem_info.default_profile_ptr, sdm_subsystem_info.profile_ptr, (sdm_subsystem_info.abbrev)); call ssu_$set_ec_search_list (sdm_invocation.sci_ptr, sdm_data_$ec_search_list); call ssu_$set_ec_suffix (sdm_invocation.sci_ptr, sdm_data_$ec_suffix); sdm_invocation.rdm_invocation_ptr = sdm_subsystem_info.rdm_invocation_ptr; /* remember the reply request (if any) */ call sdm_set_request_tables_ (sdm_invocation_ptr, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Defining the subsystem request tables."); call sdm_set_info_directories_ (sdm_invocation_ptr, code); if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Defining the subsystem info directories."); /* Add the original message text to the body of the message if requested: The original text consists of the Date, From, and Subject fields and the actual message body of the original messages. This text is indented as requested and the original message bodies are also reformatted if requested */ if sdm_subsystem_info.include_original_text then do; call sdm_text_mgr_$process_original_text (sdm_invocation_ptr, addr (sdm_subsystem_info.original_text_control), fatal_error); if fatal_error then go to RETURN_FROM_SUBSYSTEM_WITH_FATAL_ERROR; end; /* ... above call has already printed the error message */ /* Input the message body either from the terminal or the specified file */ if sdm_subsystem_info.input_type = TERMINAL_INPUT then call sdm_text_mgr_$terminal_input (sdm_invocation_ptr, input_terminator_type, edit_requests_ptr, edit_requests_lth, fatal_error); else /*** if sdm_subsystem_info.input_type = FILE_INPUT then */ do; call sdm_text_mgr_$file_input (sdm_invocation_ptr, sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename, fatal_error); input_terminator_type = NORMAL_TERMINATION; edit_requests_lth = 0; end; if fatal_error then /* above subroutines print the appropriate error messages */ go to RETURN_FROM_SUBSYSTEM_WITH_FATAL_ERROR; /* Build the initial request line */ initial_rql_lth = sdm_subsystem_info.initial_requests_lth; /* start with whatever the user requested */ if input_terminator_type = ENTER_EDITOR then /* if necessary to add qedx request */ initial_rql_lth = initial_rql_lth + length ("qedx -request """"; ") + 2 * edit_requests_lth; if sdm_invocation.fill then /* if necessary to add fill request */ initial_rql_lth = initial_rql_lth + length ("fill; "); initial_rql_lth = initial_rql_lth + length ("send; quit"); /* be sure there's enough room */ call cu_$grow_stack_frame ((divide ((initial_rql_lth + 3), 4, 18, 0) + 1), initial_rql_ptr, (0)); if ^enter_request_loop & /* user didn't explicitly ask for the request loop */ (sdm_subsystem_info.initial_requests_lth = 0) & (input_terminator_type = NORMAL_TERMINATION) then if sdm_invocation.fill then /* ... fill, send, and quit */ initial_rql = "fill; send; quit"; else initial_rql = "send; quit"; /* ... send and quit */ else do; /* user asked for the request loop ... */ initial_rql = ""; if input_terminator_type = ENTER_EDITOR then do; initial_rql = initial_rql || "qedx -request "; initial_rql = initial_rql || requote_string_ (edit_requests); initial_rql = initial_rql || "; "; /* ... supply input line via request option */ end; if sdm_invocation.fill then initial_rql = initial_rql || "fill; "; if sdm_subsystem_info.initial_requests_lth ^= 0 then initial_rql = initial_rql || user_initial_requests; end; if length (initial_rql) > 0 then do; /* execute the initial request string */ call ssu_$execute_line (sdm_invocation.sci_ptr, addwordno (initial_rql_ptr, 1), length (initial_rql), code) ; if code = ssu_et_$subsystem_aborted then go to RETURN_FROM_SUBSYSTEM; end; /* Invoke the subsystem listener */ call ssu_$listen (sdm_invocation.sci_ptr, (null ()), code); if code = ssu_et_$subsystem_aborted then code = 0; if code ^= 0 then call abort_subsystem (sdm_invocation.sci_ptr, code, "Invoking the subsystem listener."); /* That's all */ RETURN_FROM_SUBSYSTEM: P_code = sdm_invocation.abort_code; /* reflect any special conditions to the caller */ return; /* Prints an error message and aborts the attempted subsystem invocation */ abort_subsystem: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); if sdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_subsystem */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; go to RETURN_FROM_SUBSYSTEM_WITH_FATAL_ERROR; end abort_subsystem; RETURN_FROM_SUBSYSTEM_WITH_FATAL_ERROR: P_code = error_table_$fatal_error; /* we've already reported the error */ return; %page; /* Destroy a send_mail invocation */ destroy_invocation: entry (P_sdm_invocation_ptr, P_sdm_subsystem_info_ptr); sdm_invocation_ptr = P_sdm_invocation_ptr; sdm_subsystem_info_ptr = P_sdm_subsystem_info_ptr; P_sdm_invocation_ptr, /* don't try to do any of this more than once */ P_sdm_subsystem_info_ptr = null (); if sdm_subsystem_info_ptr ^= null () then do; /* get rid of input address lists if needed */ if sdm_subsystem_info.from ^= null () then call mail_system_$free_address_list (sdm_subsystem_info.from, (0)); if sdm_subsystem_info.reply_to ^= null () then call mail_system_$free_address_list (sdm_subsystem_info.reply_to, (0)); if sdm_subsystem_info.to ^= null () then call mail_system_$free_address_list (sdm_subsystem_info.to, (0)); if sdm_subsystem_info.cc ^= null () then call mail_system_$free_address_list (sdm_subsystem_info.cc, (0)); if sdm_subsystem_info.bcc ^= null () then call mail_system_$free_address_list (sdm_subsystem_info.bcc, (0)); end; if sdm_invocation_ptr ^= null () then do; /* get rid of the message and subsystem invocation */ if sdm_invocation.message_ptr ^= null () then call mail_system_$free_message (sdm_invocation.message_ptr, (0)); if sdm_invocation.sci_ptr ^= null () then /* ... destroying the subsystem releases the area */ call ssu_$destroy_invocation (sdm_invocation.sci_ptr); end; return; %page; %include sdm_invocation; %page; %include sdm_subsystem_info; %page; %include send_mail_options; %page; %include sdm_original_messages; %page; %include sdm_data; %page; %include sdm_text_mgr_constants; %page; %include mlsys_data; %page; %include mlsys_address_types; %page; %include mlsys_address_list; %page; %include mlsys_message; %page; %include area_info; %page; %include ssu_prompt_modes; end sdm_subsystem_;  sdm_text_mgr_.pl1 05/22/86 1102.1r w 05/22/86 1010.8 247734 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* Manager for the text of the message being created by the send_mail subsystem */ /* Created: 1 January 1979 by G. Palter */ /* Modified: 9 January 1979 by G. Palter to implement the fill_text entry */ /* Modified: 11 January 1979 by G. Palter to fix bug causing OOB's in terminal_input */ /* Modified: 24 January 1979 by G. Palter to add process_original_text entry */ /* Modified: 31 January 1979 by G. Palter to change filling of indented lines, fix bug in handling original text, and add a program_interrupt handler to terminal_input entry */ /* Modified: 2 January 1980 by G. Palter to fix send_mail bug #003 -- filling the message text occasionally leaves whitespace at the end of lines */ /* Modified: 17 September 1982 by G. Palter to fix mail_system error #0360 -- if -include_original is used along with -input_file, the reply message will contain nulls for the input file rather then the actual text */ /* Modified: 31 March 1983 by G. Palter to use format_document_ to fill text */ /* Modified: September 1983 by G. Palter to convert to new mail system interface and to fix mail_system error #0359 -- the header fields included as part of the original message(s) are reformatted if the user requests that the original message(s) be reformatted */ /* Modified: 8 March 1984 by G. Palter to fix error #0418 -- when replying to a message which has been forwarded with comments, the "-include_original" control argument should cause the comments to be added to the text of the reply message */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ sdm_text_mgr_: procedure (); return; /* not an entrypoint */ /* Common Parameters */ dcl P_sdm_invocation_ptr pointer parameter; dcl P_fatal_error bit (1) aligned parameter; /* set ON => an unrecoverable error occured */ /* process_original_text Parameters */ dcl P_original_text_control_ptr pointer parameter; /* -> description of how to process the original text */ /* terminal_input Parameters */ dcl P_input_terminator_type fixed binary parameter; /* set to type of termination (normal/request-loop/qedx) */ dcl P_edit_requests_ptr pointer parameter; /* set -> editor requests input by user (if any) */ dcl P_edit_requests_lth fixed binary (21) parameter; /* set to length of the editor requests */ /* file_input Parameters */ dcl P_input_file_dirname character (*) parameter; /* directory containing the input file */ dcl P_input_file_ename character (*) parameter; /* entryname of the input file */ /* fill_text Parameters */ dcl P_fill_width fixed binary parameter; /* width to use for formatting the text */ /* Local copies of parameters */ dcl 1 original_text_control like send_mail_options.original_text_control aligned based (original_text_control_ptr); dcl original_text_control_ptr pointer; dcl edit_requests character (edit_requests_lth) unaligned based (edit_requests_ptr); dcl edit_requests_ptr pointer; dcl edit_requests_lth fixed binary (21); dcl terminator_type fixed binary; /* type of terminator seen in text */ /* Remaining declarations */ dcl original_buffer character (4 * sys_info$max_seg_size) unaligned based (original_buffer_ptr); dcl original_text character (original_text_lth) unaligned based (original_buffer_ptr); dcl original_buffer_ptr pointer; dcl original_text_lth fixed binary (21); dcl fdoc_buffer character (4 * sys_info$max_seg_size) unaligned based (fdoc_buffer_ptr); dcl fdoc_buffer_ptr pointer; dcl fdoc_text_lth fixed binary (21); dcl 1 local_mbsp aligned like message_body_section_parameter; dcl 1 local_fdo aligned like format_document_options; dcl message_idx fixed binary; dcl the_character character (1) aligned; dcl (input_line_lth, idx) fixed binary (21); dcl last_character_of_sequence fixed binary; dcl input_file_ptr pointer; dcl input_file_bc fixed binary (24); dcl code fixed binary (35); dcl NL character (1) static options (constant) initial (" "); dcl sys_info$max_seg_size fixed binary (19) external; dcl iox_$error_output pointer external; dcl iox_$user_input pointer external; /* format: off */ dcl (error_table_$recoverable_error, error_table_$smallarg, mlsys_et_$message_too_large) fixed binary (35) external; /* format: on */ dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$cl entry (bit (36) aligned); dcl cu_$generate_call entry (entry, pointer); dcl format_document_$string entry (character (*), character (*), fixed binary (21), pointer, fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl ioa_ entry () options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl iox_$get_line entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mail_system_$add_body_section entry (pointer, pointer, fixed binary, fixed binary (35)); dcl mail_system_$replace_body entry (pointer, pointer, fixed binary (35)); dcl mlsys_utils_$format_address_list_field entry (character (*) varying, pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_date_time_field entry (character (*) varying, fixed binary (71), bit (1) aligned, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_message_body entry (pointer, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (35)); dcl mlsys_utils_$format_redistributions_list entry (pointer, fixed binary, fixed binary, pointer, fixed binary (21), fixed binary (21), fixed binary (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 pathname_ entry (character (*), character (*)) returns (character (168)); dcl ssu_$get_temp_segment entry (pointer, character (*), pointer); dcl ssu_$print_message entry () options (variable); dcl ssu_$release_temp_segment entry (pointer, pointer); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl (cleanup, program_interrupt) condition; dcl (addr, clock, divide, index, length, null, string, substr) builtin; %page; /* Adds the original message text to the body of the message: The original text consists of the Date, From, and Subject fields, any redistributions with comments, and the actual message body of the original messages. This text is indented as requested and the original message bodies are also reformatted if requested. The messages are processed backwards in order to allow this entrypoint to be called when the message body isn't empty which will be the case when the include_original request is implemented */ process_original_text: entry (P_sdm_invocation_ptr, P_original_text_control_ptr, P_fatal_error); sdm_invocation_ptr = P_sdm_invocation_ptr; original_text_control_ptr = P_original_text_control_ptr; P_fatal_error = "0"b; /* until proven otherwise */ if sdm_invocation.original_messages_ptr = null () then return; original_messages_ptr = sdm_invocation.original_messages_ptr; if original_messages.n_original_messages = 0 then return; input_file_ptr, /* for cleanup handler */ original_buffer_ptr, fdoc_buffer_ptr = null (); on condition (cleanup) call release_text_mgr_buffers (); call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "original-text", original_buffer_ptr); if original_buffer_ptr = null () then /* ssu_$get_temp_segment has already printed the message */ go to RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR; call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "fdoc-text", fdoc_buffer_ptr); if fdoc_buffer_ptr = null () then go to RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR; local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; local_mbsp.section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_body_section_ptr = addr (local_mbsp.section); /*** Setup format_document_ options */ local_fdo.version_number = format_document_version_2; if original_text_control.flags.indent_original_text then local_fdo.indentation = original_text_control.original_text_indentation; else local_fdo.indentation = 0; local_fdo.line_length = sdm_invocation.fill_width; string (local_fdo.switches) = ""b; local_fdo.galley_sw = "1"b; /* ... don't insert page breaks */ local_fdo.literal_sw = "1"b; /* ... don't recognize controls in the text */ local_fdo.dont_break_indented_lines_sw = "1"b; /* ... don't break lines which are indented */ local_fdo.syllable_size = 0; /* Original message processing loop ... */ do message_idx = original_messages.n_original_messages to 1 by -1; message_ptr = original_messages.messages (message_idx).message_ptr; /* ... Process the body of the original message first */ original_text_lth = 0; /* nothing in the buffer yet */ call mlsys_utils_$format_message_body (message_ptr, -1, original_buffer_ptr, length (original_buffer), original_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message body from message #^d.", original_messages.messages (message_idx).message_idx); if original_text_control.flags.indent_original_text | original_text_control.flags.fill_original_text then do; local_fdo.dont_fill_sw = ^original_text_control.flags.fill_original_text; call format_document_$string (original_text, fdoc_buffer, fdoc_text_lth, addr (local_fdo), code); if code = error_table_$recoverable_error then code = 0; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, mlsys_et_$message_too_large, "Attempting to include the message body from message #^d.", original_messages.messages (message_idx).message_idx); message_preformatted_body_section.text_ptr = fdoc_buffer_ptr; message_preformatted_body_section.text_lth = fdoc_text_lth; end; else do; /* text is already properly formatted */ message_preformatted_body_section.text_ptr = original_buffer_ptr; message_preformatted_body_section.text_lth = original_text_lth; end; call mail_system_$add_body_section (sdm_invocation.message_ptr, addr (local_mbsp), (1), code); if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message body from message #^d.", original_messages.messages (message_idx).message_idx); /* ... Now add the Date, From, and Subject fields and any redistributions with comments */ original_text_lth = 0; /* nothing in the buffer again */ call mlsys_utils_$format_date_time_field (DATE_TIME_CREATED_FIELDNAME, message.date_time_created, "0"b, (local_fdo.line_length - local_fdo.indentation), original_buffer_ptr, length (original_buffer), original_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); call add_newline (); /* formatting entrypoints leave off the trailing newline */ call mlsys_utils_$format_address_list_field (FROM_FIELDNAME, message.from, (local_fdo.line_length - local_fdo.indentation), original_buffer_ptr, length (original_buffer), original_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); call add_newline (); /* formatting entrypoints leave off the trailing newline */ if message.subject.text_lth ^= 0 then do; call mlsys_utils_$format_text_field (SUBJECT_FIELDNAME, message_subject, "0"b, (local_fdo.line_length - local_fdo.indentation), original_buffer_ptr, length (original_buffer), original_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); call add_newline (); /* formatting entrypoints leave off the trailing newline */ end; if message.n_redistributions > 0 then do; call mlsys_utils_$format_redistributions_list (message_ptr, BRIEF_FORMATTING_MODE, (local_fdo.line_length - local_fdo.indentation), original_buffer_ptr, length (original_buffer), original_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); end; if original_text_control.flags.indent_original_text then do; local_fdo.dont_fill_sw = "1"b; /* ... never reformat the header fields: just indent them */ call format_document_$string (original_text, fdoc_buffer, fdoc_text_lth, addr (local_fdo), code); if code = error_table_$recoverable_error then code = 0; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, mlsys_et_$message_too_large, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); message_preformatted_body_section.text_ptr = fdoc_buffer_ptr; message_preformatted_body_section.text_lth = fdoc_text_lth; end; else do; /* header is already properly formatted */ message_preformatted_body_section.text_ptr = original_buffer_ptr; message_preformatted_body_section.text_lth = original_text_lth; end; call mail_system_$add_body_section (sdm_invocation.message_ptr, addr (local_mbsp), (1), code); if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); sdm_invocation.date_time_body_modified = clock (); /* for psuedo Date/Message-ID fields */ end; if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; call release_text_mgr_buffers (); P_fatal_error = "0"b; return; /* Adds a newline to the buffer to separate the Date, From, and Subject fields of the original message */ add_newline: procedure (); if (original_text_lth + length (NL)) > length (original_buffer) then call abort_text_mgr (sdm_invocation.sci_ptr, mlsys_et_$message_too_large, "Attempting to include the message header from message #^d.", original_messages.messages (message_idx).message_idx); begin; dcl newline_piece character (length (NL)) unaligned defined (original_buffer) position (original_text_lth + 1); newline_piece = NL; end; original_text_lth = original_text_lth + length (NL); return; end add_newline; %page; /* format: off */ /* Reads the text of the message from the terminal: the possible terminators for the text are: '.' end of input '\fq' end of input, enter request loop, and '\f...' end of input, enter editor with given requests (if any) */ /* format: on */ terminal_input: entry (P_sdm_invocation_ptr, P_input_terminator_type, P_edit_requests_ptr, P_edit_requests_lth, P_fatal_error); sdm_invocation_ptr = P_sdm_invocation_ptr; input_file_ptr, /* for cleanup handler */ original_buffer_ptr, fdoc_buffer_ptr = null (); on condition (cleanup) call release_text_mgr_buffers (); call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "original-text", original_buffer_ptr); if original_buffer_ptr = null () then /* ssu_$get_temp_segment has already printed the message */ go to RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR; original_text_lth = 0; /* nothing read yet */ edit_requests_lth = 0; /* no editor requests yet */ on condition (program_interrupt) begin; /* stop reading if the user asks us ... */ terminator_type = ENTER_REQUEST_LOOP; go to END_OF_INPUT; end; call ioa_ ("Message:"); /* Message reading loop ... */ terminator_type = 0; /* really need do until ... */ input_line_lth = 0; do while (terminator_type = 0); original_text_lth = original_text_lth + input_line_lth; begin; dcl rest_of_original_buffer character (length (original_buffer) - original_text_lth) unaligned defined (original_buffer) position (original_text_lth + 1); call iox_$get_line (iox_$user_input, addr (rest_of_original_buffer), length (rest_of_original_buffer), input_line_lth, code); if code ^= 0 then /* ... all errors fatal when an entire segment available */ call abort_text_mgr (sdm_invocation.sci_ptr, code, "Reading the message text."); /* ... Search for terminators */ begin; dcl input_line character (input_line_lth) unaligned defined (original_buffer) position (original_text_lth + 1); if input_line_lth = 2 then if substr (input_line, 1, 1) = "." then terminator_type = NORMAL_TERMINATION; else ; else do; /* look for escape (\) sequences */ idx = index (input_line, "\"); do while (idx ^= 0); /* ... while there are \'s in line */ original_text_lth = original_text_lth + idx - 1; /* ... include everything before the \ in the text */ input_line_lth = input_line_lth - idx + 1; begin; dcl input_line character (input_line_lth) unaligned defined (original_buffer) position (original_text_lth + 1); if input_line_lth >= 2 then do; /* ... stuff after \ on line */ the_character = substr (input_line, 2, 1); if the_character = "f" then do; /*** \f...: terminates input and maybe enters the editor */ if input_line_lth >= 3 then if substr (input_line, 3, 1) = "q" then do; /* ... special case \fq to go straight to request loop */ last_character_of_sequence = 3; go to PROCESS_ENTER_REQUEST_LOOP_ESCAPE; end; terminator_type = ENTER_EDITOR; if input_line_lth >= 4 then do; /* ... if anything after \f and before NL */ edit_requests_lth = input_line_lth - 3; allocate edit_requests in (sdm_area) set (edit_requests_ptr); edit_requests = substr (input_line, 3, edit_requests_lth); end; end; else if the_character = "q" then do; /*** \q or \fq: enter request loop */ last_character_of_sequence = 2; PROCESS_ENTER_REQUEST_LOOP_ESCAPE: terminator_type = ENTER_REQUEST_LOOP; if input_line_lth >= (last_character_of_sequence + 2) then call ssu_$print_message (sdm_invocation.sci_ptr, code, "Text after ""^a"" ignored.", substr (input_line, 1, last_character_of_sequence)); end; else if the_character = "c" then do; /*** \c: escape the next character */ substr (input_line, 1, input_line_lth - 2) = substr (input_line, 3); original_text_lth = original_text_lth + 1; input_line_lth = input_line_lth - 3; end; else do; /*** unknown: take it literally */ original_text_lth = original_text_lth + 1; input_line_lth = input_line_lth - 1; end; end; end; begin; dcl input_line character (input_line_lth) unaligned defined (original_buffer) position (original_text_lth + 1); if terminator_type = 0 then idx = index (input_line, "\"); else idx = 0; end; end; end; end; end; end; /* We have the message now */ END_OF_INPUT: local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; local_mbsp.section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_body_section_ptr = addr (local_mbsp.section); message_preformatted_body_section.text_ptr = original_buffer_ptr; message_preformatted_body_section.text_lth = original_text_lth; call mail_system_$add_body_section (sdm_invocation.message_ptr, addr (local_mbsp), (-1), code); if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to place the message text into the message."); sdm_invocation.date_time_body_modified = clock ();/* for psuedo Date/Message-ID fields */ if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; call release_text_mgr_buffers (); P_input_terminator_type = terminator_type; /* tell the caller what to do next */ if edit_requests_lth ^= 0 then /* there are some editing requests */ P_edit_requests_ptr = edit_requests_ptr; else P_edit_requests_ptr = null (); P_edit_requests_lth = edit_requests_lth; P_fatal_error = "0"b; /* success */ return; %page; /* Reads the text of the message from the specified segment */ file_input: entry (P_sdm_invocation_ptr, P_input_file_dirname, P_input_file_ename, P_fatal_error); sdm_invocation_ptr = P_sdm_invocation_ptr; input_file_ptr, /* for cleanup handler */ original_buffer_ptr, fdoc_buffer_ptr = null (); on condition (cleanup) call release_text_mgr_buffers (); call initiate_file_ (P_input_file_dirname, P_input_file_ename, R_ACCESS, input_file_ptr, input_file_bc, code); if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "^a", pathname_ (P_input_file_dirname, P_input_file_ename)); local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; local_mbsp.section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_body_section_ptr = addr (local_mbsp.section); message_preformatted_body_section.text_ptr = input_file_ptr; message_preformatted_body_section.text_lth = divide ((input_file_bc + 8), 9, 21, 0); call mail_system_$add_body_section (sdm_invocation.message_ptr, addr (local_mbsp), (-1), code); if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to place the input file (^a) into the messsage.", pathname_ (P_input_file_dirname, P_input_file_ename)); sdm_invocation.date_time_body_modified = clock ();/* for psuedo Date/Message-ID fields */ if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; call release_text_mgr_buffers (); P_fatal_error = "0"b; /* success */ return; %page; /* Reformats the message body text using format_document_ with fill-on and align-left modes */ fill_text: entry (P_sdm_invocation_ptr, P_fill_width, P_fatal_error); sdm_invocation_ptr = P_sdm_invocation_ptr; input_file_ptr, /* for cleanup handler */ original_buffer_ptr, fdoc_buffer_ptr = null (); on condition (cleanup) call release_text_mgr_buffers (); call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "original-text", original_buffer_ptr); if original_buffer_ptr = null () then /* ssu_$get_temp_segment has already printed the message */ go to RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR; call ssu_$get_temp_segment (sdm_invocation.sci_ptr, "fdoc-text", fdoc_buffer_ptr); if fdoc_buffer_ptr = null () then go to RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR; original_text_lth = 0; /* nothing in the buffer yet */ call mlsys_utils_$format_message_body (sdm_invocation.message_ptr, -1, original_buffer_ptr, length (original_buffer), original_text_lth, code); if code = error_table_$smallarg then code = mlsys_et_$message_too_large; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to obtain the present message text for reformatting."); /*** Setup format_document_ options */ local_fdo.version_number = format_document_version_2; local_fdo.indentation = 0; local_fdo.line_length = P_fill_width; /* ... let caller control the width */ string (local_fdo.switches) = ""b; local_fdo.galley_sw = "1"b; /* ... don't insert page breaks */ local_fdo.literal_sw = "1"b; /* ... don't recognize controls in the text */ local_fdo.dont_break_indented_lines_sw = "1"b; /* ... don't break lines which are indented */ local_fdo.syllable_size = 0; call format_document_$string (original_text, fdoc_buffer, fdoc_text_lth, addr (local_fdo), code); if code = error_table_$recoverable_error then code = 0; if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to reformat the message text."); local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; local_mbsp.section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; message_body_section_ptr = addr (local_mbsp.section); message_preformatted_body_section.text_ptr = fdoc_buffer_ptr; message_preformatted_body_section.text_lth = fdoc_text_lth; call mail_system_$replace_body (sdm_invocation.message_ptr, addr (local_mbsp), code); if code ^= 0 then call abort_text_mgr (sdm_invocation.sci_ptr, code, "Attempting to place the reformatted message text into the message."); sdm_invocation.date_time_body_modified = clock ();/* for psuedo Date/Message-ID fields */ if sdm_invocation.message_state = PROCESSED_MESSAGE then sdm_invocation.message_state = MODIFIED_MESSAGE; call release_text_mgr_buffers (); P_fatal_error = "0"b; /* success */ return; %page; /* Releases the buffers used by text manager operations */ release_text_mgr_buffers: procedure (); if fdoc_buffer_ptr ^= null () then call ssu_$release_temp_segment (sdm_invocation.sci_ptr, fdoc_buffer_ptr); if original_buffer_ptr ^= null () then call ssu_$release_temp_segment (sdm_invocation.sci_ptr, original_buffer_ptr); if input_file_ptr ^= null () then call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); return; end release_text_mgr_buffers; /* Prints an error message and aborts execution of the current text manager operation */ abort_text_mgr: procedure () options (variable); call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr ()); if sdm_invocation.debug_mode then do; /* simulate the actions of ssu_$abort_line */ call ioa_$ioa_switch (iox_$error_output, "ssu_error_: Debug mode set; calling cu_$cl."); call cu_$cl (""b); end; go to RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR; end abort_text_mgr; RETURN_FROM_TEXT_MGR_WITH_FATAL_ERROR: call release_text_mgr_buffers (); P_fatal_error = "1"b; /* informs caller that we've already printed the message */ return; %page; %include sdm_invocation; %page; %include sdm_original_messages; %page; %include send_mail_options; %page; %include sdm_text_mgr_constants; %page; %include mlsys_message; %page; %include mlsys_field_names; %page; %include mlsys_format_options; %page; %include format_document_options; %page; %include access_mode_values; %page; %include terminate_file; end sdm_text_mgr_;  send_mail.pl1 04/09/85 1556.2r w 04/08/85 1131.6 171477 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* The Multics send_mail command */ /* Written: 1 January 1978 by G. Palter */ /* Modified: 12 January 1978 by G. Palter to reflect change in sdm_subsystem_ return codes */ /* Modified: 15 January 1979 by G. Palter to add "-abort"/"-no_abort" and stop recognizing the undocumented "-file_input" */ /* Modified: 1 February 1979 by G. Palter to enforce a minimum line length of twenty */ /* Modified: 9 February 1979 by G. Palter to fix bug 038 wherein -save command line option produced unpredictable results */ /* Modified: 25 December 1979 by W. Olin Sibert to support auto_fill mode */ /* Modified: 4 April 1980 by G. Palter to fix bug #077 -- Use of send_mail as an active function is highly unrewarding */ /* Modified: 25 April 1980 by G. Palter to implement suggestion #084 -- Provide abbrev expansion of read_mail and send_mail request lines; add the "-abbrev", "-no_abbrev", and "-profile" control arguments */ /* Modified: 20 May 1980 by G. Palter to fix bug #0314 -- error message printed for a non-existant profile contains an extraneous "]" */ /* Modified: 4 June 1980 by G. Palter to implement suggestion #0287 -- if a reply is being created and the user exits send_mail without sending the reply, the "-delete" control argument of the "reply" request should be ignored */ /* Modified: 27 January 1981 by G. Palter to use cu_$arg_count rather than cu_$af_return_arg */ /* Modified: 16 February 1982 by G. Palter to convert to version 4 sdm_subsystem_info -- default profiles */ /* Modified: 2 March 1982 by G. Palter to eliminate a window which prevented subsystem invocations from being destroyed */ /* Modified: 17 September 1982 by G. Palter to add -debug/-no_debug, change definition of -fill and eliminate -auto_fill, and change prompting and request loop control */ /* Modified: August 1983 by G. Palter to convert to the new mail system interface. As part of this conversion: (1) The -header/-no_header and -message_id/-no_message_id control arguments are still accepted but no longer have any meaning as the user ring can not control the amount of header information recorded in a message; (2) The -bcc control argument is accepted to add addresses the the bcc field (mail_system 0284); (3) Logbox and savebox addresses are now added to the bcc field instead of the cc field; (4) The command will create the logbox and offer to create saveboxes before reading the message text; if the user refuses to create the savebox, it will be considered an invalid address (mail_system 0228); (5) The command will, by default, abort before asking for the message text if any of the addresses on the command line is invalid (mail_system 0191, 229). The -abort/-no_abort control argument is changed to indicate whether such invalid addresses should abort the command or cause send_mail to enter the request loop */ /* Modified: April 1984 by G. Palter to fix mail system error #0433 -- the send_mail command and all send_mail and read_mail requests which accept multiple addresses as arguments do not properly parse "-log -at HOST" */ /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ send_mail: sdm: procedure () options (variable); dcl 1 local_pcao aligned like parse_ca_options; dcl argument character (argument_lth) unaligned based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl profile_pathname character (profile_pathname_lth) unaligned based (profile_pathname_ptr); dcl profile_dirname character (168); dcl profile_ename character (32); dcl profile_pathname_ptr pointer; dcl profile_pathname_lth fixed binary (21); dcl (profile_pathname_given, abbrev_ca_given) bit (1) aligned; dcl input_filename character (input_filename_lth) unaligned based (input_filename_ptr); dcl (input_filename_ptr, input_file_ptr) pointer; dcl input_filename_lth fixed binary (21); dcl current_address_list_ptr pointer based (current_address_list_ptr_ptr); dcl current_address_list_ptr_ptr pointer; dcl sci_ptr pointer; /* -> subsystem used to parse command line arguments */ dcl sdm_invocation_ptr pointer; /* -> description of the send_mail invocation */ dcl abort bit (1) aligned; /* ON => don't enter subsystem if any addresses are invalid */ dcl found_invalid_address bit (1) aligned; /* ON => there really are some invalid addresses present */ dcl code fixed binary (35); dcl SEND_MAIL character (32) static options (constant) initial ("send_mail"); /* format: off */ dcl (error_table_$bad_arg, error_table_$bad_conversion, error_table_$badopt, error_table_$fatal_error, error_table_$noarg, emf_et_$send_mail_aborted, mlsys_et_$ca_parse_failed, mlsys_et_$cant_parse_irt_field) fixed binary (35) external; /* format: on */ dcl active_fnc_err_ entry () options (variable); dcl com_err_ entry () options (variable); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35)); dcl cu_$arg_list_ptr entry () returns (pointer); dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl mlsys_utils_$parse_address_list_control_args entry (pointer, fixed binary, pointer, character (8), pointer, pointer, fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl sdm_subsystem_$create_invocation entry (character (8), pointer, pointer, fixed binary (35)); dcl sdm_subsystem_$destroy_invocation entry (pointer, pointer); dcl sdm_subsystem_$subsystem entry (pointer, pointer, fixed binary (35)); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_count entry (pointer, fixed binary); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$destroy_invocation entry (pointer); dcl ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35)); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl cleanup condition; dcl (addr, index, null) builtin; %page; /* send_mail: sdm: procedure () options (variable) */ sci_ptr, /* for cleanup handler */ sdm_invocation_ptr, sdm_subsystem_info_ptr, input_file_ptr = null (); on condition (cleanup) call cleanup_send_mail_command (); call ssu_$standalone_invocation (sci_ptr, SEND_MAIL, "argument-parse", cu_$arg_list_ptr (), abort_send_mail_command, code); if code ^= 0 then do; /* please forgive the following, but ... */ if cu_$af_return_arg (0, (null ()), (0)) = 0 then call active_fnc_err_ (code, SEND_MAIL, "Can not establish standalone subsystem invocation."); else call com_err_ (code, SEND_MAIL, "Can not establish standalone subsystem invocation."); return; end; call ssu_$arg_count (sci_ptr, n_arguments); /* aborts if not a command */ call sdm_subsystem_$create_invocation (SDM_SUBSYSTEM_INFO_VERSION_6, sdm_invocation_ptr, sdm_subsystem_info_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Creating the subsystem."); /* Argument processing */ current_address_list_ptr_ptr = addr (sdm_subsystem_info.to); /* defaults to -to */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = CREATE_AND_ANNOUNCE_MAILBOX; local_pcao.savebox_creation_mode = QUERY_TO_CREATE_MAILBOX; local_pcao.abort_on_errors = "0"b; /* can't abort in case -no_abort appears somewhere */ local_pcao.validate_addresses = "1"b; /* always check validity of addresses */ local_pcao.mbz = ""b; abort = "1"b; /* abort if any invalid addresses are found */ found_invalid_address = "0"b; /* until proven otherwise */ abbrev_ca_given = "0"b; /* haven't seen -abbrev/-no_abbrev yet */ profile_pathname_given = "0"b; /* haven't seen -profile yet */ argument_idx = 1; /* start at the beginning */ do while (argument_idx <= n_arguments); call mlsys_utils_$parse_address_list_control_args (sci_ptr, argument_idx, addr (local_pcao), ADDRESS_LIST_VERSION_2, current_address_list_ptr, sdm_subsystem_info.bcc, code); if (code ^= 0) & (code ^= mlsys_et_$ca_parse_failed) then call ssu_$abort_subsystem (sci_ptr, code, "Parsing control arguments."); found_invalid_address = found_invalid_address | (code = mlsys_et_$ca_parse_failed); /* need to know whether to abort or not ... */ if argument_idx <= n_arguments then do; /*** An argument not recognized by the mail system: must be one of ours */ call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-terminal_input") | (argument = "-ti") then sdm_subsystem_info.input_type = TERMINAL_INPUT; else if (argument = "-input_file") | (argument = "-if") then do; call get_next_argument ("A pathname"); sdm_subsystem_info.input_type = FILE_INPUT; input_filename_ptr = argument_ptr; input_filename_lth = argument_lth; end; /* save it for later processing */ else if argument = "-from" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.from); else if (argument = "-reply_to") | (argument = "-rpt") then current_address_list_ptr_ptr = addr (sdm_subsystem_info.reply_to); else if argument = "-to" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.to); else if argument = "-cc" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.cc); else if argument = "-bcc" then current_address_list_ptr_ptr = addr (sdm_subsystem_info.bcc); else if (argument = "-subject") | (argument = "-sj") then do; call get_next_argument ("A string"); sdm_subsystem_info.subject_given = "1"b; sdm_subsystem_info.subject_ptr = argument_ptr; sdm_subsystem_info.subject_lth = argument_lth; end; else if (argument = "-no_subject") | (argument = "-nsj") then do; sdm_subsystem_info.subject_given = "1"b; sdm_subsystem_info.subject_lth = 0; end; else if argument = "-abort" then abort = "1"b; else if argument = "-no_abort" then abort = "0"b; else if (argument = "-acknowledge") | (argument = "-ack") then sdm_subsystem_info.acknowledge = "1"b; else if (argument = "-no_acknowledge") | (argument = "-nack") then sdm_subsystem_info.acknowledge = "0"b; else if (argument = "-brief") | (argument = "-bf") then sdm_subsystem_info.brief = "1"b; else if (argument = "-long") | (argument = "-lg") then sdm_subsystem_info.brief = "0"b; else if (argument = "-fill") | (argument = "-fi") then sdm_subsystem_info.fill_control = FILL; else if (argument = "-no_fill") | (argument = "-nfi") then sdm_subsystem_info.fill_control = NO_FILL; else if (argument = "-line_length") | (argument = "-ll") then do; call get_next_argument ("A number"); sdm_subsystem_info.fill_width = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion, "-line_length ""^a""", argument); if sdm_subsystem_info.fill_width < 31 then call ssu_$abort_subsystem (sci_ptr, 0, "Line length must be greater than 30."); end; else if (argument = "-notify") | (argument = "-nt") then sdm_subsystem_info.notify = "1"b; else if (argument = "-no_notify") | (argument = "-nnt") then sdm_subsystem_info.notify = "0"b; /*** Control arguments required by the MCR boards despite the furious objections of the author */ else if argument = "-auto_write" then sdm_subsystem_info.auto_write = "1"b; else if argument = "-no_auto_write" then sdm_subsystem_info.auto_write = "0"b; /*** Control arguments which are now obsolete: delete in MR11 */ else if (argument = "-in_reply_to") | (argument = "-irt") then do; call get_next_argument ("A string"); call ssu_$abort_subsystem (sci_ptr, mlsys_et_$cant_parse_irt_field, "-in_reply_to ""^a""", argument); end; else if (argument = "-header") | (argument = "-he") | (argument = "-no_header") | (argument = "-nhe") then ; else if (argument = "-message_id") | (argument = "-mid") | (argument = "-no_message_id") | (argument = "-nmid") then ; /*** Standard subsystem control arguments */ else if (argument = "-abbrev") | (argument = "-ab") then sdm_subsystem_info.abbrev, abbrev_ca_given = "1"b; else if (argument = "-no_abbrev") | (argument = "-nab") then do; sdm_subsystem_info.abbrev = "0"b; abbrev_ca_given = "1"b; end; else if (argument = "-profile") | (argument = "-pf") then do; call get_next_argument ("A pathname"); profile_pathname_given = "1"b; profile_pathname_ptr = argument_ptr; profile_pathname_lth = argument_lth; end; /* save for later processing */ else if (argument = "-debug") | (argument = "-db") then sdm_subsystem_info.debug = "1"b; else if (argument = "-no_debug") | (argument = "-ndb") then sdm_subsystem_info.debug = "0"b; else if (argument = "-prompt") | (argument = "-pmt") then do; call get_next_argument ("A string"); if argument_lth = 0 then /* same as -no_prompt */ sdm_subsystem_info.prompt_control.prompt_control = NO_PROMPT; else do; sdm_subsystem_info.prompt_control.prompt_control = USE_PROMPT_STRING; sdm_subsystem_info.prompt_string = argument; end; end; else if (argument = "-no_prompt") | (argument = "-npmt") then sdm_subsystem_info.prompt_control.prompt_control = NO_PROMPT; else if (argument = "-request") | (argument = "-rq") then do; call get_next_argument ("A string"); sdm_subsystem_info.initial_requests_ptr = argument_ptr; sdm_subsystem_info.initial_requests_lth = argument_lth; end; else if (argument = "-request_loop") | (argument = "-rql") then sdm_subsystem_info.request_loop_control = REQUEST_LOOP; else if (argument = "-no_request_loop") | (argument = "-nrql") then sdm_subsystem_info.request_loop_control = NO_REQUEST_LOOP; else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else call ssu_$abort_subsystem (sci_ptr, error_table_$bad_arg, """^a""", argument); argument_idx = argument_idx + 1; /* continue with next argument (if any) */ end; end; /* Verify that the input file requested by the user actually exists */ if sdm_subsystem_info.input_type = FILE_INPUT then do; call expand_pathname_ (input_filename, sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-input_file ""^a""", input_filename); call initiate_file_ (sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename, R_ACCESS, input_file_ptr, (0), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-input_file ""^a""", pathname_ (sdm_subsystem_info.input_file.dname, sdm_subsystem_info.input_file.ename)); call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); end; /* Initiate the subsystem profile requested by the user */ if profile_pathname_given then do; call expand_pathname_$add_suffix (profile_pathname, "profile", profile_dirname, profile_ename, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-profile ""^a""", profile_pathname); call initiate_file_ (profile_dirname, profile_ename, R_ACCESS, sdm_subsystem_info.default_profile_ptr, (0), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-profile ""^a""", pathname_ (profile_dirname, profile_ename)); if ^abbrev_ca_given then /* -profile implies -abbrev unless explicit -ab/-nab given */ sdm_subsystem_info.abbrev = "1"b; end; /* Abort the entire subsystem invocation or force the subsystem to enter the request loop if invalid addresses were found according to the use of -abort/-no_abort and then invoke the subsystem */ if found_invalid_address then /* there are indeed invalid addresses ... */ if abort then /* ... and the user doesn't want to continue */ call ssu_$abort_subsystem (sci_ptr, 0); else sdm_subsystem_info.request_loop_control = REQUEST_LOOP; /* ... force the user to fix the addresses */ call sdm_subsystem_$subsystem (sdm_invocation_ptr, sdm_subsystem_info_ptr, code); if (code ^= 0) & (code ^= error_table_$fatal_error) & (code ^= emf_et_$send_mail_aborted) then call ssu_$abort_subsystem (sci_ptr, code, "Invoking the subsystem."); /* Cleanup */ RETURN_FROM_SEND_MAIL: call cleanup_send_mail_command (); return; %page; /* Releases all temporary data obtained by this send_mail invocation */ cleanup_send_mail_command: procedure (); if input_file_ptr ^= null () then call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0)); if (sdm_invocation_ptr ^= null ()) | (sdm_subsystem_info_ptr ^= null ()) then call sdm_subsystem_$destroy_invocation (sdm_invocation_ptr, sdm_subsystem_info_ptr); if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end cleanup_send_mail_command; /* Invoked by ssu_$abort_subsystem/ssu_$abort_line to terminate the send_mail invocation */ abort_send_mail_command: procedure (); go to RETURN_FROM_SEND_MAIL; end abort_send_mail_command; /* Fetches the next argument for control arguments which require values */ get_next_argument: procedure (p_string); dcl p_string character (*) parameter; if argument_idx = n_arguments then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "^a after ""^a"".", p_string, argument); argument_idx = argument_idx + 1; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); return; end get_next_argument; %page; %include sdm_subsystem_info; %page; %include send_mail_options; %page; %include mlsys_data; %page; %include mlsys_parse_ca_options; %page; %include mlsys_address_list; %page; %include access_mode_values; %page; %include terminate_file; end send_mail; 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