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) ali