accept_messages.pl1 05/20/87 1526.9rew 05/20/87 1423.1 212337 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This command accepts messages on the specified mailbox. */ /****^ HISTORY COMMENTS: 1) change(84-05-31,Lippard), approve(), audit(), install(): Written by Jim Lippard. 2) change(84-11-21,Lippard), approve(), audit(), install(): Modified to use call string for -print when appropriate. 3) change(85-01-11,Lippard), approve(), audit(), install(): Modified to use new calling sequences for message_facility_$(delete_message print_message read_message set_seen_switch). 4) change(86-01-05,Lippard), approve(86-05-27,MCR7418), audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080): Modified to abort if user decides not to create a nonexistent mailbox. 5) change(87-01-29,Lippard), approve(87-03-18,MECR0001), audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002): Modified to strip control characters out of message comment field. 6) change(87-01-29,Lippard), approve(87-04-20,MCR7669), audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032): Formal installation to close out MECR0001. END HISTORY COMMENTS */ accept_messages: am: procedure options (variable); dcl ME char (15) internal static options (constant) init ("accept_messages"); dcl VERSION char (3) internal static options (constant) init ("1.3"); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible; dcl canonicalize_ entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (35)); dcl com_err_ entry () options (variable); dcl command_query_$yes_no entry () options (variable); dcl convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_authorization_ entry () returns (bit (72) aligned) reducible; dcl get_system_free_area_ entry () returns (ptr); dcl (ioa_, ioa_$rsnnl) entry () options (variable); dcl iox_$user_output ptr ext static; dcl mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35)); dcl mailbox_$create entry (char (*), char (*), fixed bin (35)); dcl mailbox_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl message_facility_$default_alarm_handler entry (ptr, ptr); dcl message_facility_$default_wakeup_handler entry (ptr, ptr); dcl message_facility_$delete_message entry (ptr, bit (72) aligned, fixed bin (35)); dcl message_facility_$get_message_format entry (ptr, bit (1) aligned, fixed bin (35)); dcl message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35)); dcl message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35)); dcl message_facility_$read_message entry (ptr, bit (72) aligned, ptr, ptr, fixed bin (35)); dcl message_facility_$set_alarm_handler entry (ptr, entry, ptr, fixed bin (71), fixed bin (35)); dcl message_facility_$set_message_format entry (ptr, bit (1) aligned, fixed bin (35)); dcl message_facility_$set_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35)); dcl message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35)); dcl message_facility_$set_wakeup_handler entry (ptr, entry, ptr, fixed bin (35)); dcl message_facility_$set_wakeup_state entry (ptr, bit (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl cleanup condition; dcl alarm_time fixed bin (71); dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl authorization bit (72) aligned; dcl auth_string char (170); dcl alarm bit (1) aligned; dcl brief bit (1) aligned; dcl call bit (1) aligned; dcl 1 call_string_info aligned based (call_string_info_ptr), 2 uid bit (36) aligned, 2 call_string_ptr ptr, 2 next_call_string_ptr ptr; dcl call_string_info_ptr ptr; dcl static_call_string_info_ptr ptr internal static init (null ()); dcl call_string char (512) based (call_string_info.call_string_ptr); dcl temp_call_string char (512); dcl command_line char (2000); dcl create_mbx bit (1) aligned; dcl date_time fixed bin (71); dcl default bit (1) aligned; dcl dname char (168); dcl ename char (32); dcl flags bit (5); dcl 1 local_wf like wakeup_flags based (local_wf_ptr); dcl local_wf_ptr ptr; dcl flush_time fixed bin (71); dcl found bit (1) aligned; dcl hold bit (1) aligned; dcl nohold bit (1) aligned; dcl hold_notify bit (1) aligned; dcl nohold_notify bit (1) aligned; dcl idx fixed bin; dcl last_msg_time char (24); dcl last_sender char (120); dcl last_time fixed bin (71); dcl 1 local_mi aligned like message_info; dcl 1 local_pcao aligned like parse_ca_options; dcl mail bit (1) aligned; dcl nomail bit (1) aligned; dcl message_sender char (120); dcl msg_date_time char (24); dcl msgf_mbx_ptr ptr; dcl path bit (1) aligned; dcl pathname char (256); dcl person char (22); dcl project char (9); dcl prefix_string char (32) varying; dcl prefix bit (1) aligned; dcl print bit (1) aligned; dcl sci_ptr ptr; dcl short_format bit (1) aligned; dcl no_short_format bit (1) aligned; dcl short_format_switch bit (1) aligned; dcl new_short_format_switch bit (1) aligned; dcl short bit (1) aligned; dcl short_prefix bit (1) aligned; dcl sys_area area based (sys_area_ptr); dcl sys_area_ptr ptr; dcl tag char (10) var; dcl uid bit (36) aligned; dcl (addr, before, collate, convert, fixed, index, length, maxlength, null, rtrim, string, substr, translate) builtin; dcl (conversion, size) condition; dcl code fixed bin (35); dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl ALPHABET char (256) init ((8)" " || " " || (4)" " || "" || (16)" " || substr (collate (), 33)); /* space, BSHT, space, RRSBRS, space, alphanumerics */ dcl NLSPHT char (3) internal static options (constant) init (" "); dcl BS char (1) aligned internal static options (constant) init (""); dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); dcl FIVE_MINUTES fixed bin (71) internal static options (constant) init (300000000); /* initialize variables */ alarm, brief, call, default, hold, nohold, hold_notify, nohold_notify, nomail, path, print, short_format, no_short_format = FALSE; mail, short_prefix = TRUE; last_msg_time, last_sender = ""; last_time = 0; alarm_time, flush_time = 0; temp_call_string = ""; prefix_string = ""; prefix = FALSE; call_string_info_ptr, msg_array_ptr, sci_ptr = null (); sys_area_ptr = get_system_free_area_ (); on cleanup call cleanup_am; /* create ssu_ invocation */ call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_am, code); if code ^= 0 then do; call com_err_ (code, ME, "Creating standalone subsystem invocation."); return; end; /* process arguments */ call ssu_$arg_count (sci_ptr, arg_count); do idx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg = "-brief" | arg = "-bf" then brief, short_format = TRUE; else if arg = "-long" | arg = "-lg" then do; short_format = FALSE; no_short_format = TRUE; end; else if arg = "-call" then do; idx = idx + 1; if idx > arg_count then temp_call_string = ""; else do; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if index (arg, "-") = 1 then do; temp_call_string = ""; idx = idx - 1; end; else do; if arg_len > length (temp_call_string) then call ssu_$abort_line (sci_ptr, (0), "Call string may not be longer than ^d characters. ^a", length (temp_call_string), arg); temp_call_string = arg; end; end; call = TRUE; end; else if arg = "-flush" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A flush time must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call convert_date_to_binary_ (arg, flush_time, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); end; else if arg = "-hold" | arg = "-hd" | arg = "-hold_messages" | arg = "-hdmsg" then do; hold = TRUE; nohold = FALSE; end; else if arg = "-no_hold" | arg = "-nhd" | arg = "-no_hold_messages" | arg = "-nhdmsg" then do; hold = FALSE; nohold = TRUE; alarm_time = 0; end; else if arg = "-hold_notifications" | arg = "-hdnt" then do; hold_notify = TRUE; nohold_notify = FALSE; mail = TRUE; nomail = FALSE; end; else if arg = "-no_hold_notifications" | arg = "-nhdnt" then do; hold_notify = FALSE; nohold_notify = TRUE; end; else if arg = "-mail" | arg = "-ml" | arg = "-notifications" | arg = "-nt" then do; mail = TRUE; nomail = FALSE; end; else if arg = "-no_mail" | arg = "-nml" | arg = "-no_notifications" | arg = "-nnt" then do; mail = FALSE; nomail = TRUE; hold_notify = FALSE; nohold_notify = TRUE; end; else if arg = "-pathname" | arg = "-pn" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A pathname must be specified after ""^a"".", arg); if path then call ssu_$abort_line (sci_ptr, (0), "Usage: am {mbx_specification} {-control_args}"); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); path = TRUE; end; else if arg = "-prefix" | arg = "-pfx" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A prefix must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg_len > maxlength (prefix_string) then call ssu_$abort_line (sci_ptr, (0), "Prefix may not be longer than ^d characters. ^a", maxlength (prefix_string), arg); prefix_string = arg; prefix = TRUE; end; else if arg = "-print" | arg = "-pr" then print = TRUE; else if arg = "-no_print" | arg = "-npr" then print = FALSE; else if arg = "-short" | arg = "-sh" then do; short_format = TRUE; no_short_format = FALSE; end; else if arg = "-short_prefix" | arg = "-shpfx" then short_prefix = TRUE; else if arg = "-no_short_prefix" | arg = "-nshpfx" then short_prefix = FALSE; else if arg = "-time" | arg = "-tm" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "An alarm time must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); on conversion, size go to BAD_TIME; alarm_time = 60 * convert (alarm_time, arg); revert conversion, size; hold = TRUE; nohold = FALSE; alarm = TRUE; end; else do; /* let mlsys_utils_ have at it */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = TRUE; local_pcao.validate_addresses = FALSE; local_pcao.mbz = ""b; call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); idx = idx - 1; if path then call ssu_$abort_line (sci_ptr, (0), "Usage: am {msg_specification} {-control_args}"); path = TRUE; end; end; if ^path then do; call user_info_$whoami (person, project, ""); dname = ">udd>" || rtrim (project) || ">" || person; ename = rtrim (person) || ".mbx"; default = TRUE; end; call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); if code = error_table_$noentry then do; /* if default, create it; otherwise ask */ if ^default then call command_query_$yes_no (create_mbx, code, ME, "Answer ""yes"" if you want the mailbox to be created.", "Do you want to create the mailbox ^a?", pathname_ (dname, ename)); if create_mbx | default then do; call mailbox_$create (dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Creating ^[default ^]mailbox ^a.", default, pathname_ (dname, ename)); end; else call abort_am (); if ^brief then call ioa_ ("Creating ^[default ^]mailbox ^a.", default, pathname_ (dname, ename)); call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); end; if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting message facility mailbox pointer. ^a", pathname_ (dname, ename)); /* get wakeup state */ call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting wakeup state. ^a", pathname_ (dname, ename)); local_wf_ptr = addr (flags); local_wf.wakeup_state = ACCEPT_MESSAGES; if nohold then local_wf.hold_messages = FALSE; else if hold then local_wf.hold_messages = TRUE; if nohold_notify then local_wf.hold_notifications = FALSE; else if hold_notify then local_wf.hold_notifications = TRUE; if nomail then local_wf.print_notifications = FALSE; else if mail then local_wf.print_notifications = TRUE; call message_facility_$set_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting wakeup state. ^a", pathname_ (dname, ename)); /* set prefix */ if prefix then do; call message_facility_$set_prefix (msgf_mbx_ptr, prefix_string, short_prefix, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting prefix. ^a", pathname_ (dname, ename)); end; /* set message format */ call message_facility_$get_message_format (msgf_mbx_ptr, short_format_switch, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting message format. ^a", pathname_ (dname, ename)); if short_format then new_short_format_switch = TRUE; else if no_short_format then new_short_format_switch = FALSE; else new_short_format_switch = short_format_switch; if new_short_format_switch ^= short_format_switch then do; call message_facility_$set_message_format (msgf_mbx_ptr, new_short_format_switch, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting message format. ^a", pathname_ (dname, ename)); end; /* take care of call string */ call mailbox_$get_uid_file (dname, ename, uid, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting mailbox UID. ^a", pathname_ (dname, ename)); call_string_info_ptr = static_call_string_info_ptr; found = FALSE; do while (call_string_info_ptr ^= null () & ^found); if call_string_info.uid = uid then found = TRUE; else call_string_info_ptr = call_string_info.next_call_string_ptr; end; if found & call then call_string = temp_call_string; else if ^found then do; allocate call_string_info in (sys_area); call_string_info.uid = uid; allocate call_string in (sys_area); if call then call_string = temp_call_string; else call_string = ""; call_string_info.next_call_string_ptr = static_call_string_info_ptr; static_call_string_info_ptr = call_string_info_ptr; end; /* set alarm handler */ if alarm then do; call message_facility_$set_alarm_handler (msgf_mbx_ptr, message_facility_$default_alarm_handler, addr (call_string), alarm_time, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting alarm handler. ^a", pathname_ (dname, ename)); end; if print | flush_time ^= 0 then do; /* only get msg array for print or flush */ call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting message array pointer. ^a", pathname_ (dname, ename)); /* print old messages */ if print then do; do idx = 1 to n_messages; call print_message (idx, msg_array.message_id (idx)); end; end; /* flush messages from before flush_time */ if flush_time ^= 0 then do; do idx = 1 to n_messages; if fixed (substr (msg_array.message_id (idx), 19, 54), 71) < flush_time then do; call message_facility_$delete_message (msgf_mbx_ptr, msg_array.message_id (idx), code); end; end; end; end; /* only get msg array for print or flush */ /* set wakeup handler */ call message_facility_$set_wakeup_handler (msgf_mbx_ptr, message_facility_$default_wakeup_handler, addr (call_string), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Setting wakeup handler. ^a", pathname_ (dname, ename)); call cleanup_am; RETURN_FROM_AM: return; BAD_TIME: call ssu_$abort_line (sci_ptr, (0), """^a"" is not a decimal integer.", arg); return; /* This procedure removes control characters (except backspace, tab, red ribbon shift, and black ribbon shift) and canonicalizes strings to prevent backspacing past the front of the string. */ canon: procedure (P_string, P_string_len) returns (char (*)); dcl P_string char (*) parm; dcl P_string_len fixed bin (21) parm; dcl output_string char (P_string_len); P_string = translate (P_string, ALPHABET); if index (P_string, BS) ^= 0 then do; output_string = ""; call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0)); return (output_string); end; else return (P_string); end canon; /* This procedure prints a message. */ print_message: procedure (P_message_index, P_message_id); dcl P_message_index fixed bin parm; dcl P_message_id bit (72) aligned parm; mail_format_ptr = null (); local_mi.version = MESSAGE_INFO_VERSION_1; on cleanup begin; if mail_format_ptr ^= null () then free mail_format in (sys_area); mail_format_ptr = null (); end; call message_facility_$read_message (msgf_mbx_ptr, P_message_id, sys_area_ptr, addr (local_mi), code); if code ^= 0 then return; mail_format_ptr = local_mi.message_ptr; date_time = fixed (substr (P_message_id, 19, 54), 71); call date_time_ (date_time, msg_date_time); /* create message sender string */ if mail_format.sent_from = before (local_mi.sender, ".") | rtrim (mail_format.sent_from) = "" then message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2); else message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2) || " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")"; authorization = get_authorization_ (); if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do; call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code); if auth_string = "" then auth_string = "system_low"; message_sender = rtrim (message_sender) || " at " || auth_string; end; if message_sender = last_sender then short = TRUE; else short = FALSE; if temp_call_string ^= "" then do; call ioa_$rsnnl (" ^d ", tag, (0), msg_array.message_number (P_message_index)); if default then pathname = ""; else pathname = requote_string_ (pathname_ (dname, ename)); command_line = rtrim (temp_call_string) || " " || tag || requote_string_ (rtrim (message_sender)) || " " || requote_string_ (rtrim (date_time_$format ("date_time", date_time, "", ""))) || " " || requote_string_ (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT))))) || " " || pathname; call cu_$cp (addr (command_line), length (rtrim (command_line)), (0)); end; else do; string (msg_print_flags) = ""b; /* print prefix, it may contain ioa_ controls */ if ^short | short_prefix then msg_print_flags.print_prefix = TRUE; /* if not default mailbox, prefix with mailbox entry name */ if ^default then msg_print_flags.print_ename = TRUE; if ^short_format_switch | ^short then msg_print_flags.print_sender = TRUE; if ^short_format_switch | substr (msg_date_time, 1, 8) ^= last_msg_time then msg_print_flags.print_date_and_time = TRUE; else if date_time - last_time > FIVE_MINUTES then msg_print_flags.print_time = TRUE; last_sender = message_sender; last_time = date_time; last_msg_time = substr (msg_date_time, 1, 8); call message_facility_$print_message (msgf_mbx_ptr, iox_$user_output, P_message_id, addr (msg_print_flags), code); call message_facility_$set_seen_switch (msgf_mbx_ptr, P_message_id, DELETE_UNHELD, code); if mail_format_ptr ^= null () then do; free mail_format in (sys_area); mail_format_ptr = null (); end; end; end print_message; cleanup_am: proc; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); if msg_array_ptr ^= null () then free msg_array in (sys_area); return; end cleanup_am; abort_am: proc; call cleanup_am; go to RETURN_FROM_AM; end abort_am; %page; %include mail_format; %page; %include message_info; %page; %include mlsys_parse_ca_options; %page; %include msg_array; %page; %include msg_print_flags; %page; %include msg_wakeup_flags; end accept_messages;  defer_messages.pl1 01/07/85 1505.6rew 01/07/85 1418.2 66681 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This module implements the following commands: defer_messages (dm) - command to defer printing of interactive messages until either the immediate_messages or accept_messages commands are used. immediate_messages (im) - command to resume printing of interactive messages. */ /* Written 12/26/83 by Jim Lippard */ /* Modified 11/30/84 by Jim Lippard to make immediate_messages print out messages received while messages were not being accepted. */ /* Modified 12/12/84 by Jim Lippard to make immediate_messages print all unseen messages. */ defer_messages: dm: procedure options (variable); dcl ME char (18); dcl VERSION char (3) internal static options (constant) initial ("1.2"); dcl com_err_ entry () options (variable); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35)); dcl message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35)); dcl message_facility_$set_wakeup_state entry (ptr, bit (*), fixed bin (35)); dcl message_facility_$wakeup_processor entry (ptr); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl cleanup condition; dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl new_wakeup_state bit (2) aligned; dcl dname char (168); dcl ename char (32); dcl flags bit (5); dcl idx fixed bin; dcl 1 local_eci aligned like event_call_info; dcl 1 local_pcao aligned like parse_ca_options; dcl msgf_mbx_ptr ptr; dcl path bit (1) aligned; dcl person char (22); dcl project char (9); dcl sci_ptr ptr; dcl sys_area_ptr ptr; dcl sys_area area based (sys_area_ptr); dcl (addr, null, rtrim, unspec) builtin; dcl code fixed bin (35); dcl error_table_$noarg fixed bin (35) ext static; dcl TRUE bit (1) internal static options (constant) init ("1"b); dcl FALSE bit (1) internal static options (constant) init ("0"b); ME = "defer_messages"; new_wakeup_state = DEFER_MESSAGES; go to COMMON; immediate_messages: im: entry; ME = "immediate_messages"; new_wakeup_state = ACCEPT_MESSAGES; COMMON: /* initialize variables */ path = FALSE; msg_array_ptr, sci_ptr, sys_area_ptr = null (); on cleanup call cleanup_dm; /* create ssu_ invocation */ call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_dm, code); if code ^= 0 then do; call com_err_ (code, ME, "Creating standalone subsystem invocation."); return; end; /* process arguments */ call ssu_$arg_count (sci_ptr, arg_count); do idx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg = "-pathname" | arg = "-pn" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A pathname must be specified after ""^a"".", arg); if path then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[dm^;im^] {mbx_specification}", (ME = "defer_messages")); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); path = TRUE; end; else do; /* let mlsys_utils_ have at it */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = TRUE; local_pcao.validate_addresses = FALSE; local_pcao.mbz = ""b; call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); if path then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[dm^;im^] {mbx_specification}", (ME = "defer_messages")); idx = idx - 1; path = TRUE; end; end; if ^path then do; call user_info_$whoami (person, project, ""); dname = ">udd>" || rtrim (project) || ">" || rtrim (person); ename = rtrim (person) || ".mbx"; end; call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); if new_wakeup_state = ACCEPT_MESSAGES then do; /* immediate_messages needs to print "pending" messages */ sys_area_ptr = get_system_free_area_ (); call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Getting message array pointer. ^a", pathname_ (dname, ename)); do idx = 1 to n_messages; if ^msg_array.printed (idx) then call print_message (idx); end; end; addr (flags) -> wakeup_flags.wakeup_state = new_wakeup_state; call message_facility_$set_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); call cleanup_dm; RETURN_FROM_DM: return; cleanup_dm: proc; if msg_array_ptr ^= null () then free msg_array in (sys_area); if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end; abort_dm: proc; call cleanup_dm; go to RETURN_FROM_DM; end abort_dm; /* This procedure prints a message. */ print_message: procedure (P_message_index); dcl P_message_index fixed bin parm; /* Set up bogotified event_call_info. None of this info is used except for local_eci.message and local_eci.data_ptr. */ local_eci.channel_id = 0; unspec (local_eci.message) = unspec (msg_array.message_id (P_message_index)); local_eci.sender = ""b; local_eci.dev_signal = ""b; local_eci.ring = 0; local_eci.data_ptr = msgf_mbx_ptr; call message_facility_$wakeup_processor (addr (local_eci)); end print_message; %page; %include event_call_info; %page; %include mlsys_parse_ca_options; %page; %include msg_array; %page; %include msg_wakeup_flags; end defer_messages;  delete_message.pl1 12/01/87 0759.6rew 11/30/87 1322.5 313074 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This module implements the following commands: delete_message (dlm) - deletes interactive messages print_messages (pm) - prints interactive messages */ /****^ HISTORY COMMENTS: 1) change(84-06-04,Lippard), approve(), audit(), install(): Written by Jim Lippard. 2) change(84-11-08,Lippard), approve(), audit(), install(): Modified to call set_seen_switch even when -call is used. 3) change(84-11-16,Lippard), approve(), audit(), install(): Modified to improve message printed when no messages are selected. 4) change(84-11-23,Lippard), approve(), audit(), install(): Modified to complain for each message not printed/deleted (except in ranges). 5) change(85-01-11,Lippard), approve(), audit(), install(): Modified to use new calling sequences for message_facility_$(read_message delete_message print_message set_seen_switch) and to complain about negative message numbers. 6) change(85-01-23,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to print "You have no messages" on user_output and make dlm say when all messages have been deleted (when -message_status is specified). 7) change(85-08-15,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to ignore case for keywords and to print a better error message for "dlm -a" when there are only unseen messages. 8) change(87-01-29,Lippard), approve(87-03-18,MECR0001), audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002): Modified to strip control characters out of message comment field. 9) change(87-05-08,Lippard), approve(87-04-20,MCR7669), audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032): Formal installation to close out MECR0001. 10) change(87-08-25,Lippard), approve(87-08-24,MCR7761), audit(87-09-25,Dickson), install(87-11-30,MR12.2-1006): Remove -verbose control argument (original name of -message_status). END HISTORY COMMENTS */ delete_message: dlm: procedure options (variable); dcl ME char (14); dcl VERSION char (3) internal static options (constant) init ("1.4"); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned); dcl canonicalize_ entry (ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl com_err_ entry () options (variable); dcl convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_authorization_ entry () returns (bit (72) aligned) reducible; dcl get_system_free_area_ entry () returns (ptr); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl iox_$user_output ptr ext static; dcl mailbox_$create entry (char (*), char (*), fixed bin (35)); dcl mailbox_$get_mode_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35)); dcl message_facility_$delete_message entry (ptr, bit (72) aligned, fixed bin (35)); dcl message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35)); dcl message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$get_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35)); dcl message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35)); dcl message_facility_$read_message entry (ptr, bit (72) aligned, ptr, ptr, fixed bin (35)); dcl message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$print_message entry () options (variable); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl cleanup condition; dcl after_sw bit (1) aligned; dcl after_date_time fixed bin (71); dcl all bit (1) aligned; dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl authorization bit (72) aligned; dcl auth_string char (170); dcl before_sw bit (1) aligned; dcl before_date_time fixed bin (71); dcl brief bit (1) aligned; dcl call_string char (512); dcl command_line char (2000); dcl comment bit (1) aligned; dcl comment_string char (32); dcl date_time fixed bin (71); dcl delete bit (1) aligned; dcl default bit (1) aligned; dcl dname char (168); dcl ename char (32); dcl exclude bit (1) aligned; dcl exclude_string char (256); dcl extended_mode bit (36) aligned; dcl force bit (1) aligned; dcl from bit (1) aligned; dcl from_string char (32); dcl found bit (1) aligned; dcl actual_hold_flags bit (3); dcl 1 hold_flags unaligned based (hold_flags_ptr), 2 delete_unheld bit (1), 2 hold_messages bit (1), 2 hold_notifications bit (1); dcl hold_flags_ptr ptr; dcl hold_messages bit (1) aligned; dcl no_hold_messages bit (1) aligned; dcl hold_notifications bit (1) aligned; dcl no_hold_notifications bit (1) aligned; dcl (idx, jdx) fixed bin; dcl last bit (1) aligned; dcl last_msg_time char (24); dcl last_sender char (120); dcl last_time fixed bin (71); dcl 1 local_lmi aligned like last_message_info; dcl 1 local_mi aligned like message_info; dcl 1 local_pcao aligned like parse_ca_options; dcl match bit (1) aligned; dcl match_string char (256); dcl message_sender char (120); dcl msg_date_time char (24); dcl msgf_mbx_ptr ptr; dcl 1 msg_spec (50) aligned, 2 start fixed bin, 2 start_spec bit (1) aligned, 2 end fixed bin, 2 end_spec bit (1) aligned, 2 found bit (1) aligned, 2 arg char (256); dcl n_msg_specs fixed bin; dcl messages bit (1) aligned; dcl no_messages bit (1) aligned; dcl notifications bit (1) aligned; dcl no_notifications bit (1) aligned; dcl message_status bit (1) aligned; dcl (start, end) fixed bin; dcl new bit (1) aligned; dcl own bit (1) aligned; dcl path bit (1) aligned; dcl pathname char (256); dcl person char (22); dcl project char (9); dcl prefix_string char (32) varying; dcl print bit (1) aligned; dcl sci_ptr ptr; dcl short bit (1) aligned; dcl short_format bit (1) aligned; dcl short_prefix bit (1) aligned; dcl something_done bit (1) aligned; dcl sys_area area based (sys_area_ptr); dcl sys_area_ptr ptr; dcl tag char (10) varying; dcl (addr, after, before, collate, convert, fixed, hbound, index, length, null, rtrim, string, substr, translate) builtin; dcl code fixed bin (35); dcl error_table_$inconsistent fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$no_message fixed bin (35) ext static; dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); dcl ALPHABET char (256) init ((8)" " || " " || (4)" " || "" || (16)" " || substr (collate (), 33)); /* space, BSHT, space, RRSBRS, space, alphanumerics */ dcl FIVE_MINUTES fixed bin (71) internal static options (constant) init (300000000); dcl FIRST_MESSAGE fixed bin internal static options (constant) init (-2); dcl LAST_MESSAGE fixed bin internal static options (constant) init (-1); dcl NLSPHT char (3) internal static options (constant) init (" "); dcl BS char (1) internal static options (constant) init (""); dcl UPPERCASE char (26) internal static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl LOWERCASE char (26) internal static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); ME = "delete_message"; delete = TRUE; print = FALSE; go to COMMON; print_messages: pm: entry; ME = "print_messages"; delete = FALSE; print = TRUE; COMMON: /* initialize variables */ after_sw, all, before_sw, brief, comment, default, exclude, force, from, last, match, new, path = FALSE; /* The following assignments are separate to avoid a PL/I bug, see TR phx17760 */ message_status = FALSE; messages = FALSE; no_messages = FALSE; notifications = FALSE; no_notifications = FALSE; hold_messages = FALSE; no_hold_messages = FALSE; hold_notifications = FALSE; no_hold_notifications = FALSE; short_format = TRUE; last_msg_time, last_sender = ""; call_string, from_string, match_string, exclude_string = ""; last_time = 0; n_msg_specs = 0; mail_format_ptr, msg_array_ptr, sci_ptr = null (); sys_area_ptr = get_system_free_area_ (); on cleanup call cleanup_dlm; /* create ssu_ invocation */ call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_dlm, code); if code ^= 0 then do; call com_err_ (code, ME, "Creating standalone subsystem invocation."); return; end; /* process arguments */ call ssu_$arg_count (sci_ptr, arg_count); do idx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg = "-after" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A date/time must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if after_sw then call ssu_$abort_line (sci_ptr, (0), "Only one -after date/time may be specified. ^a", arg); call convert_date_to_binary_ (arg, after_date_time, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); after_sw = TRUE; end; else if arg = "-all" | arg = "-a" then all = TRUE; else if arg = "-before" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A date/time must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if before_sw then call ssu_$abort_line (sci_ptr, (0), "Only one -before date/time may be specified. ^a", arg); call convert_date_to_binary_ (arg, before_date_time, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); before_sw = TRUE; end; else if arg = "-brief" | arg = "-bf" then brief = TRUE; else if arg = "-long" | arg = "-lg" then do; if print then short_format = FALSE; brief = FALSE; end; else if (arg = "-short" | arg = "-sh") then do; if print then short_format = TRUE; else message_status = FALSE; end; else if arg = "-message_status" | arg = "-msgst" then message_status = TRUE; else if arg = "-no_message_status" | arg = "-nmsgst" then message_status = FALSE; else if arg = "-call" & print then do; idx = idx + 1; if idx > arg_count then call_string = ""; else do; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if index (arg, "-") = 1 then do; call_string = ""; idx = idx - 1; end; else do; if arg_len > length (call_string) then call ssu_$abort_line (sci_ptr, (0), "Call string may not be longer than ^d characters. ^a", length (call_string), arg); call_string = arg; end; end; end; else if arg = "-comment" | arg = "-com" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A comment string must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if comment then call ssu_$abort_line (sci_ptr, (0), "Only one comment string may be supplied. ^a", arg); if arg_len > length (comment_string) then call ssu_$abort_line (sci_ptr, (0), "Comment string may not be longer than ^d characters. ^a", length (comment_string), arg); comment_string = arg; comment = TRUE; end; else if arg = "-exclude" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "An exclude string must be specified after ""a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if exclude then call ssu_$abort_line (sci_ptr, (0), "Only one exclude string may be specified. ^a", arg); if arg_len > length (exclude_string) then call ssu_$abort_line (sci_ptr, (0), "Exclude string may not be longer than ^d characters. ^a", length (exclude_string), arg); exclude_string = arg; exclude = TRUE; end; else if (arg = "-force" | arg = "-fc") & delete then force = TRUE; else if (arg = "-no_force" | arg = "-nfc") & delete then force = FALSE; else if arg = "-from" | arg = "-fm" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A from string must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if from then call ssu_$abort_line (sci_ptr, (0), "Only one from string may be specified. ^a", arg); if arg_len > length (from_string) then call ssu_$abort_line (sci_ptr, (0), "From string may not be longer than ^d characters. ^a", length (from_string), arg); from_string = arg; from = TRUE; end; else if (arg = "-hold_messages" | arg = "-hdmsg") & print then do; hold_messages = TRUE; no_hold_messages = FALSE; end; else if (arg = "-no_hold_messages" | arg = "-nhdmsg") & print then do; hold_messages = FALSE; no_hold_messages = TRUE; end; else if (arg = "-hold_notifications" | arg = "-hdnt") & print then do; hold_notifications = TRUE; no_hold_notifications = FALSE; end; else if (arg = "-no_hold_notifications" | arg = "-nhdnt") & print then do; hold_notifications = FALSE; no_hold_notifications = TRUE; end; else if (arg = "-last" | arg = "-lt") & print then last = TRUE; else if arg = "-match" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A match string must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if match then call ssu_$abort_line (sci_ptr, (0), "Only one match string may be specified. ^a", arg); if arg_len > length (match_string) then call ssu_$abort_line (sci_ptr, (0), "Match string may not be longer than ^d characters. ^a", length (match_string), arg); match_string = arg; match = TRUE; end; else if arg = "-messages" | arg = "-msg" then do; messages = TRUE; no_messages = FALSE; end; else if arg = "-no_messages" | arg = "-nmsg" then do; messages = FALSE; no_messages = TRUE; end; else if arg = "-notifications" | arg = "-nt" then do; notifications = TRUE; no_notifications = FALSE; end; else if arg = "-no_notifications" | arg = "-nnt" then do; notifications = FALSE; no_notifications = TRUE; end; else if arg = "-new" & print then new = TRUE; else if arg = "-pathname" | arg = "-pn" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A pathname must be specified after ""^a"".", arg); if path then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[dlm^;pm^] ^[{^]msg_specs^[}^] {mbx_specification} {-control_args}", delete, print, print); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); path = TRUE; end; else do; /* msg spec or mbx spec */ start = get_msg_spec (arg, code); if code = 0 then end = start; else if index (arg, ":") ^= 0 then do; start = get_msg_spec (before (arg, ":"), code); if code = 0 then end = get_msg_spec (after (arg, ":"), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, (0), "Invalid message range. ^a", arg); end; if code = 0 then do; n_msg_specs = n_msg_specs + 1; if n_msg_specs > hbound (msg_spec, 1) then call ssu_$abort_line (sci_ptr, (0), "Too many message specifiers given, maximum of ^d.", hbound (msg_spec, 1)); msg_spec.start (n_msg_specs) = start; if msg_spec.start (n_msg_specs) < 0 then msg_spec.start_spec (n_msg_specs) = TRUE; else msg_spec.start_spec (n_msg_specs) = FALSE; msg_spec.end (n_msg_specs) = end; if msg_spec.end (n_msg_specs) < 0 then msg_spec.end_spec (n_msg_specs) = TRUE; else msg_spec.end_spec (n_msg_specs) = FALSE; msg_spec.found (n_msg_specs) = FALSE; msg_spec.arg (n_msg_specs) = arg; end; else if translate (arg, LOWERCASE, UPPERCASE) = "all" | translate (arg, LOWERCASE, UPPERCASE) = "a" then all = TRUE; else do; /* mbx specification */ /* let mlsys_utils_ have at it */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = TRUE; local_pcao.validate_addresses = FALSE; local_pcao.mbz = ""b; call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); idx = idx - 1; if path then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[dlm^;pm^] ^[{^]msg_specs^[}^] {mbx_specification} {-control_args}", delete, print, print); path = TRUE; end; /* mbx spec */ end; /* msg spec or mbx spec */ end; /* arg loop */ if no_messages & no_notifications then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-no_messages and -no_notifications"); if last & (after_sw | before_sw | comment | from | match | exclude | messages | notifications | no_messages | no_notifications | hold_messages | hold_notifications | no_hold_messages | no_hold_notifications | n_msg_specs ^= 0 | all | new) then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "No message selection arguments may be given with -last."); if no_messages then notifications = TRUE; else if no_notifications then messages = TRUE; if n_msg_specs = 0 then do; if delete & (after_sw | before_sw | comment | from | match | exclude | messages | notifications) then all = TRUE; if delete & ^all then call ssu_$abort_line (sci_ptr, (0), "Usage: dlm msg_specs {mbx_specification} {-control_args}"); if print then all = TRUE; n_msg_specs = n_msg_specs + 1; msg_spec.start (n_msg_specs) = get_msg_spec ("first", code); msg_spec.start_spec (n_msg_specs) = FALSE; msg_spec.end (n_msg_specs) = get_msg_spec ("last", code); msg_spec.end_spec (n_msg_specs) = FALSE; msg_spec.found (n_msg_specs) = FALSE; end; if messages & notifications then messages, notifications = FALSE; /* determine which messages are to be held */ actual_hold_flags = ""b; hold_flags_ptr = addr (actual_hold_flags); if hold_messages then hold_flags.hold_messages = TRUE; else if no_hold_messages then hold_flags.hold_messages = FALSE; if hold_notifications then hold_flags.hold_notifications = TRUE; else if no_hold_notifications then hold_flags.hold_notifications = FALSE; if ^(hold_messages | no_hold_messages | hold_notifications | no_hold_notifications) then actual_hold_flags = DELETE_UNHELD; if ^path then do; call user_info_$whoami (person, project, ""); dname = ">udd>" || rtrim (project) || ">" || person; ename = rtrim (person) || ".mbx"; default = TRUE; end; /* get mbx ptr */ call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); if code = error_table_$noentry & default & print then do; call mailbox_$create (dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Creating default mailbox ^a.", pathname_ (dname, ename)); call ioa_ ("Creating default mailbox ^a.", pathname_ (dname, ename)); call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); end; if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); /* get prefix */ call message_facility_$get_prefix (msgf_mbx_ptr, prefix_string, short_prefix, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); /* get mailbox mode */ call mailbox_$get_mode_file (dname, ename, extended_mode, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); own = substr (extended_mode, 3, 1); /* get msg array ptr */ call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); /* process messages */ do idx = 1 to n_msg_specs; if msg_spec.start_spec (idx) then if msg_spec.start (idx) = FIRST_MESSAGE then msg_spec.start (idx) = get_msg_spec ("first", code); else msg_spec.start (idx) = get_msg_spec ("last", code); if msg_spec.end_spec (idx) then if msg_spec.end (idx) = FIRST_MESSAGE then msg_spec.end (idx) = get_msg_spec ("first", code); else msg_spec.end (idx) = get_msg_spec ("last", code); if msg_spec.start (idx) > msg_spec.end (idx) then call ssu_$abort_line (sci_ptr, (0), "Invalid message range. ^a", msg_spec.arg (idx)); end; /* print header */ if n_messages ^= 0 & print & ^default then call ioa_ ("^[There ^[are^;is^]^;You have^s^] ^d message^[s^] in ^a.^/", own, (n_messages ^= 1), n_messages, (n_messages ^= 1), pathname_ (dname, ename)); else if n_messages = 0 & ^brief & ^last then do; call ioa_ ("^[There are^;You have^] no interactive messages^[ in ^a^].", (own & ^default), ^default, pathname_ (dname, ename)); go to MAIN_RETURN; end; /* handle -last */ if last then do; call print_message ((0), (""b)); go to MAIN_RETURN; end; something_done = FALSE; local_mi.version = MESSAGE_INFO_VERSION_1; do idx = 1 to n_messages; if msg_array.message_id (idx) ^= ""b then do; call message_facility_$read_message (msgf_mbx_ptr, msg_array.message_id (idx), sys_area_ptr, addr (local_mi), code); if code = error_table_$no_message then ; else if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While reading message ^d^[ from mailbox ^a^].", msg_array.message_number (idx), ^default, pathname_ (dname, ename)); else do; mail_format_ptr = local_mi.message_ptr; found = FALSE; if ((delete & msg_array.printed (idx)) | print | force) & (^new | ^msg_array.printed (idx)) & (^after_sw | (fixed (substr (msg_array.message_id (idx), 19, 54), 71) > after_date_time)) & (^before_sw | (fixed (substr (msg_array.message_id (idx), 19, 54), 71) < before_date_time)) & (^comment | (rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) = comment_string)) & (^from | (from_match (substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2), from_string))) & (^messages | (messages & ^mail_format.notify)) & (^notifications | (notifications & mail_format.notify)) & (^match | (index (mail_format.text, rtrim (match_string)) ^= 0)) & (^exclude | (index (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT)))), rtrim (exclude_string)) = 0)) then do; do jdx = 1 to n_msg_specs while (^found); if (msg_array.message_number (idx) >= msg_spec.start (jdx) & msg_array.message_number (idx) <= msg_spec.end (jdx)) | ((msg_array.message_number (idx) = 0 & print & something_done) | all) then do; if print then call print_message (idx, msg_array.message_id (idx)); else call message_facility_$delete_message (msgf_mbx_ptr, msg_array.message_id (idx), code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "While ^[deleting^;printing^] message ^d^[ in mailbox ^a^].", delete, msg_array.message_number (idx), ^default, pathname_ (dname, ename)); else something_done = TRUE; msg_spec.found (jdx) = TRUE; found = TRUE; end; end; /* jdx loop */ end; /* message meets specifications */ if mail_format_ptr ^= null () then do; free mail_format in (sys_area); mail_format_ptr = null (); end; end; /* message read */ end; /* non-notification */ end; /* idx loop */ if ^something_done then if ^brief then call ssu_$print_message (sci_ptr, (0), "No ^[seen ^]messages ^[to delete.^;were found that matched the selection criteria.^]", delete & ^force, delete & ^force & all); else ; else do idx = 1 to n_msg_specs; if ^msg_spec.found (idx) then call ssu_$print_message (sci_ptr, (0), "No ^[seen ^]message^[s in range^] ^a found.", delete & ^force, (index (msg_spec.arg (idx), ":") ^= 0), msg_spec.arg (idx)); end; if delete & message_status then do; if msg_array_ptr ^= null () then free msg_array in (sys_area); call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While getting message array pointer."); if n_messages = 0 then call ioa_ ("All messages have been deleted."); end; MAIN_RETURN: call cleanup_dlm; RETURN_FROM_DLM: return; /* This procedure removes control characters (except backspace, tab, red ribbon shift, and black ribbon shift) and canonicalizes strings to prevent backspacing past the front of the string. */ canon: procedure (P_string, P_string_len) returns (char (*)); dcl P_string char (*) parm; dcl P_string_len fixed bin (21) parm; dcl output_string char (P_string_len); P_string = translate (P_string, ALPHABET); if index (P_string, BS) ^= 0 then do; output_string = ""; call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0)); return (output_string); end; else return (P_string); end canon; /* This procedure parses message specifiers. */ get_msg_spec: procedure (P_arg, P_code) returns (fixed bin); dcl P_arg char (*) parm; dcl P_code fixed bin (35) parm; dcl idx fixed bin; dcl msg_spec char (5); dcl return_value fixed bin; dcl (conversion, size) condition; P_code = 0; msg_spec = translate (P_arg, LOWERCASE, UPPERCASE); if msg_spec = "first" | msg_spec = "f" then do; if msg_array_ptr = null () | n_messages = 0 then return (FIRST_MESSAGE); do idx = 1 to n_messages; if msg_array.message_number (idx) ^= 0 then return (msg_array.message_number (idx)); end; return_value = 1; end; else if msg_spec = "last" | msg_spec = "l" then do; if msg_array_ptr = null () | n_messages = 0 then return (LAST_MESSAGE); do idx = n_messages to 1 by -1; if msg_array.message_number (idx) ^= 0 then return (msg_array.message_number (idx)); end; return_value = n_messages; end; else do; if P_arg = "" then go to BAD_INTEGER; on conversion, size go to BAD_INTEGER; return_value = convert (return_value, P_arg); revert conversion, size; if return_value < 1 then go to BAD_INTEGER; end; return (return_value); BAD_INTEGER: P_code = 1; return ((0)); end get_msg_spec; /* This procedure compares a user id (person.project.tag) with a from string (Person, .Project, or Person.Project) */ from_match: procedure (P_sender, P_from_string) returns (bit (1) aligned); dcl (P_sender, P_from_string) char (*) parm; dcl person char (22); dcl project char (9); person = before (P_sender, "."); project = after (P_sender, "."); if substr (P_from_string, 1, 1) = "." then /* .Project */ if rtrim (P_from_string) = "." || rtrim (project) then return (TRUE); else ; else if index (P_from_string, ".") ^= 0 then /* Person.Project */ if rtrim (P_from_string) = rtrim (person) || "." || rtrim (project) then return (TRUE); else ; else /* Person */ if rtrim (P_from_string) = rtrim (person) then return (TRUE); return (FALSE); end from_match; /* This procedure prints a message. This same code is also present in accept_messages (-print) and message_facility_ (process_message). */ print_message: procedure (P_message_index, P_message_id); dcl P_message_index fixed bin parm; dcl P_message_id bit (72) aligned parm; dcl last_msg bit (1) aligned; string (msg_print_flags) = ""b; if P_message_index = 0 then do; /* last message */ msg_print_flags.print_last_message = TRUE; last_msg = TRUE; local_lmi.version = LAST_MESSAGE_INFO_VERSION_1; call message_facility_$get_last_message_info (msgf_mbx_ptr, addr (local_lmi), code); if code ^= 0 then return; if local_lmi.last_message_id = ""b then call ssu_$abort_line (sci_ptr, (0), "No last message."); message_info_ptr = local_lmi.last_message_ptr; local_mi = message_info; end; else do; last_msg = FALSE; on cleanup call cleanup_pm; end; mail_format_ptr = local_mi.message_ptr; if last_msg then date_time = fixed (substr (local_lmi.last_message_id, 19, 54), 71); else date_time = fixed (substr (P_message_id, 19, 54), 71); call date_time_ (date_time, msg_date_time); /* create message sender string */ if mail_format.sent_from = before (local_mi.sender, ".") | rtrim (mail_format.sent_from) = "" then message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2); else message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2) || " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")"; authorization = get_authorization_ (); if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do; call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code); if auth_string = "" then auth_string = "system_low"; message_sender = rtrim (message_sender) || " at " || auth_string; end; if call_string ^= "" then do; if last_msg then call ioa_$rsnnl (" ^d ", tag, length (tag), local_lmi.last_message_number); else call ioa_$rsnnl (" ^d ", tag, length (tag), msg_array.message_number (P_message_index)); if default then pathname = ""; else pathname = requote_string_ (pathname_ (dname, ename)); command_line = rtrim (call_string) || " " || tag || requote_string_ (rtrim (message_sender)) || " " || requote_string_ (rtrim (date_time_$format ("date_time", date_time, "", ""))) || " " || requote_string_ (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT))))) || " " || pathname; call cu_$cp (addr (command_line), length (rtrim (command_line)), (0)); end; else do; if message_sender = last_sender then short = TRUE; else short = FALSE; /* print prefix, it may contain ioa_ controls */ if ^short | short_prefix then msg_print_flags.print_prefix = TRUE; /* if not default mailbox, prefix with mailbox entry name */ if ^default then msg_print_flags.print_ename = TRUE; if ^short_format | ^short then msg_print_flags.print_sender = TRUE; if ^short_format | substr (msg_date_time, 1, 8) ^= last_msg_time then msg_print_flags.print_date_and_time = TRUE; else if date_time - last_time > FIVE_MINUTES then msg_print_flags.print_time = TRUE; last_sender = message_sender; last_time = date_time; last_msg_time = substr (msg_date_time, 1, 8); call message_facility_$print_message (msgf_mbx_ptr, iox_$user_output, P_message_id, addr (msg_print_flags), code); end; if ^last_msg then do; call message_facility_$set_seen_switch (msgf_mbx_ptr, P_message_id, actual_hold_flags, (0)); if mail_format_ptr ^= null () then do; free mail_format in (sys_area); mail_format_ptr = null (); end; end; end print_message; cleanup_dlm: proc; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); if msg_array_ptr ^= null () then free msg_array in (sys_area); return; end cleanup_dlm; abort_dlm: proc; call cleanup_dlm; go to RETURN_FROM_DLM; end abort_dlm; cleanup_pm: proc; if mail_format_ptr ^= null () then free mail_format in (sys_area); end cleanup_pm; %page; %include last_message_info; %page; %include mail_format; %page; %include message_info; %page; %include mlsys_parse_ca_options; %page; %include msg_array; %page; %include msg_print_flags; end delete_message;  last_message_info.pl1 06/30/86 1407.4r w 06/30/86 1344.2 66690 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This module implements the following command/active functions: last_message_sender (lms) - print/return the user ID of the last message sender. last_message_time (lmt) - print/return the date/time of the last message. last_message (lm) - print/return the last message. */ /* Written 05/30/84 by Jim Lippard */ last_message_info: procedure options (variable); return; /* not an entry */ dcl ME char (19); dcl VERSION char (3) internal static options (constant) init ("1.0"); dcl com_err_ entry () options (variable); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl ioa_ entry () options (variable); dcl mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35)); dcl message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl cleanup condition; dcl active_function bit (1) aligned; dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl dname char (168); dcl ename char (32); dcl idx fixed bin; dcl inhibit_error bit (1) aligned; dcl 1 local_lmi aligned like last_message_info; dcl 1 local_pcao aligned like parse_ca_options; dcl msgf_mbx_ptr ptr; dcl msg_time char (250) var; dcl path bit (1) aligned; dcl person char (22); dcl project char (9); dcl return_ptr ptr; dcl return_len fixed bin (21); dcl return_arg char (return_len) varying based (return_ptr); dcl sci_ptr ptr; dcl (addr, fixed, length, null, rtrim, substr) builtin; dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); dcl LFHTSP char (3) internal static options (constant) init (" "); dcl code fixed bin (35); dcl error_table_$noarg fixed bin (35) ext static; last_message_sender: lms: entry; ME = "last_message_sender"; go to COMMON; last_message_time: lmt: entry; ME = "last_message_time"; go to COMMON; last_message: lm: entry; ME = "last_message"; COMMON: /* initialize variables */ inhibit_error, path = FALSE; sci_ptr = null (); on cleanup call cleanup_lmi; /* create ssu_ invocation */ call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_lmi, code); if code ^= 0 then do; call com_err_ (code, ME, "Creating standalone subsystem invocation."); return; end; /* process arguments */ call ssu_$return_arg (sci_ptr, arg_count, active_function, return_ptr, return_len); do idx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = TRUE; else if arg = "-pathname" | arg = "-pn" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A pathname must be specified after ""^a"".", arg); if path then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[lms^;^[lmt^;lm^]^] {mbx_specification}", (ME = "last_message_sender"), (ME = "last_message_time")); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); path = TRUE; end; else do; /* let mlsys_utils_ have at it */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = TRUE; local_pcao.validate_addresses = FALSE; local_pcao.mbz = ""b; call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); idx = idx - 1; if path then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[lms^;^[lmt^;lm^]^] {mbx_specification}", (ME = "last_message_sender"), (ME = "last_message_time")); path = TRUE; end; end; if ^path then do; call user_info_$whoami (person, project, ""); dname = ">udd>" || rtrim (project) || ">" || person; ename = rtrim (person) || ".mbx"; end; call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); local_lmi.version = LAST_MESSAGE_INFO_VERSION_1; call message_facility_$get_last_message_info (msgf_mbx_ptr, addr (local_lmi), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); if local_lmi.last_message_id = ""b then do; if ^inhibit_error then call ssu_$abort_line (sci_ptr, (0), "No last message."); else if active_function then return_arg = ""; go to MAIN_RETURN; end; message_info_ptr = local_lmi.last_message_ptr; if ME = "last_message_sender" then do; if active_function then return_arg = requote_string_ (substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2)); else call ioa_ ("^a", substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2)); end; else if ME = "last_message_time" then do; msg_time = date_time_$format ("date_time", fixed (substr (local_lmi.last_message_id, 19, 54), 71), "", ""); if active_function then return_arg = requote_string_ ((msg_time)); else call ioa_ ("^a", msg_time); end; else if ME = "last_message" then do; mail_format_ptr = message_info.message_ptr; if active_function then return_arg = requote_string_ (rtrim (mail_format.text, LFHTSP)); else call ioa_ ("^a", rtrim (mail_format.text, LFHTSP)); end; MAIN_RETURN: call cleanup_lmi; RETURN_FROM_LMI: return; cleanup_lmi: proc; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end; abort_lmi: proc; call cleanup_lmi; go to RETURN_FROM_LMI; end abort_lmi; %page; %include last_message_info; %page; %include mail_format; %page; %include message_info; %page; %include mlsys_parse_ca_options; end last_message_info;  mail.pl1 05/20/87 1526.9rew 05/20/87 1423.2 261972 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-02,Herbst), approve(86-06-02,MCR7432), audit(86-06-30,Wong), install(86-06-30,MR12.0-1080): Fixed to zero unused portions of mail_format. 2) change(87-02-26,Lippard), approve(87-03-18,MECR0001), audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002): Modified to strip control characters from message comment field. 3) change(87-05-08,Lippard), approve(87-04-20,MCR7669), audit(87-05-11,Fawcett), install(87-05-20,MR12.1-1032): Formal installation to close out MECR0001. END HISTORY COMMENTS */ mail: ml: proc; /* Usage: mail to read own mail mail -path- to read any mail mail path user1_ proj1_ ... user_i proj_i to send a segment mail * user1_ proj1_ ... user_i proj_i to send console input Mailbox names end in ".mbx" */ /* -notify and -no_notify added 7/27/78 by S. Herbst */ /* Modified: 1 May 1985 by G. Palter to remove reference to mseg_hdr.incl.pl1 */ % include mail_format; /* this based structure should call the ASCII part "text" */ dcl 1 send_mail_info aligned, /* structure for sending acknowledgement message */ 2 version fixed bin, /* = 1 */ 2 from char (32) aligned, 2 switches, 3 wakeup bit (1) unal, 3 mbz1 bit (1) unal, 3 always_add bit (1) unal, 3 never_add bit (1) unal, 3 mbz2 bit (1) unal, 3 acknowledge bit (1) unal, 3 mbz bit (30) unal; dcl area area based (areap); dcl segment char (4096) based (segp); dcl page char (4096) aligned; dcl node_space (48) ptr aligned; /* space for first 24 deletion nodes */ dcl alphabet char (256) init /* alphabetics plus BS HT NL RRS BRS */ ((8)" " || " " || (3)" " || "" || (16)" " || substr (collate (), 33)); dcl BS char (1) internal static options (constant) init (""); dcl (buffer, dn) char (168); dcl (en, last_sender, last_sent_from, sender, sender_name) char (32); dcl atime char (24); dcl (match_person, match_project) char (32) init ("*"); dcl (exclude_person, exclude_project) char (32) init ("."); dcl name char (22); dcl proj char (9); dcl vname char (22) varying; dcl vproj char (9) varying; dcl last_date char (8); dcl command char (7); dcl answer char (3) varying; dcl s char (1) init (""); dcl nlx char (1); dcl newline char (1) init (" "); dcl arg char (al) based (ap); dcl node (24) char (16) aligned based (stack_ptr); /* deletion nodes */ dcl stack_bits bit (3456) aligned based (stack_ptr); dcl clock bit (54) aligned; dcl exmode bit (36) aligned; dcl (acknowledge, /* request acknowledgement when sending */ brief, /* -brief option when reading */ head_mode, /* -header mode when reading */ dont_print_count, console, /* sending console input */ got_input, /* already copied into "page" */ more, /* more input in input mode */ my_mbx, /* reading from user's own mailbox */ notify_sw, /* send notification with the mail */ own, /* reading own messages */ path_sw, /* read mail by pathname */ pdir_flag, /* save mail in process directory */ printing, /* printing mail */ salvaged, /* mailbox was salvaged */ saved, /* already saved in unsent_mail */ seg_initiated) /* initiated a segment to send */ bit (1) aligned init ("0"b); dcl (al, anonymous, arg_count, argno, chars, header_length, i, msg_bitcnt, nlines) fixed bin; dcl (count, mseg_index) fixed bin init (0); dcl node_index fixed bin init (0); dcl (last_type, interactive init (1), mail_type init (2)) fixed bin; dcl (five_minutes, last_time, time) fixed bin (71); dcl bitcnt fixed bin (24); dcl j fixed bin (21); dcl mode fixed bin (5); dcl chase fixed bin (1) init (1); dcl (ap, argp, idp, node_ptr) pointer; dcl (areap, mbxp, segp) pointer init (null); dcl stack_ptr ptr; dcl 1 id_node aligned based, 2 next pointer aligned, 2 delete_id bit (72) aligned; /* message id saved for deletion */ dcl 1 mseg_return_args aligned, 2 msg_ptr pointer, /* -> returned message */ 2 bitcnt fixed bin (18), /* bit count of message */ 2 sender_id char (32), /* sender's group id */ 2 level fixed bin, /* validation level */ 2 id bit (72), /* loc_and_time */ 2 sender_authorization bit (72), 2 access_class bit (72); dcl 1 query_info aligned internal static, 2 vsn fixed bin init (1), 2 yes_or_no_sw bit (1) unaligned init ("1"b), 2 suppress_name_sw bit (1) unaligned init ("0"b), 2 status_code fixed bin (35) init (0), 2 query_code fixed bin (35) init (0); dcl canonicalize_ entry (ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl com_err_ entry options (variable); dcl command_query_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$grow_stack_frame entry (fixed bin, ptr, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_pdir_ entry returns (char (168)aligned); dcl get_wdir_ entry returns (char (168)aligned); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$user_input pointer external; dcl iox_$user_output pointer external; dcl send_mail_ entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35)); dcl send_message_$notify_mail entry (char (*), char (*), fixed bin (35)); dcl user_info_ entry (char (*)); dcl user_info_$login_data entry (char (*), char (*), char (*), fixed bin); dcl mailbox_$add_index entry (fixed bin, ptr, fixed bin, bit (72)aligned, fixed bin (35)); dcl mailbox_$check_salv_bit_index entry (fixed bin, bit (1)aligned, bit (1)aligned, fixed bin (35)); dcl mailbox_$close entry (fixed bin (17), fixed bin (35)); dcl mailbox_$create entry (char (*), char (*), fixed bin (35)); dcl mailbox_$delete_index entry (fixed bin, bit (72)aligned, fixed bin (35)); dcl mailbox_$get_mode_index entry (fixed bin, bit (*)aligned, fixed bin (35)); dcl mailbox_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72)aligned, ptr, fixed bin (35)); dcl mailbox_$open entry (char (*), char (*), fixed bin, fixed bin (35)); dcl mailbox_$open_if_full entry (char (*), char (*), bit (1) aligned, fixed bin (17), fixed bin (17), fixed bin (35)); dcl mailbox_$own_incremental_read_index entry (fixed bin, ptr, bit (2), bit (72)aligned, ptr, fixed bin (35)); dcl mailbox_$own_read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35)); dcl mailbox_$read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35)); dcl mailbox_$update_message_index entry (fixed bin, fixed bin, bit (72)aligned, ptr, fixed bin (35)); dcl code fixed bin (35); dcl error_table_$bad_segment fixed bin (35) external; dcl error_table_$badopt fixed bin (35) external; dcl error_table_$long_record fixed bin (35) external; dcl error_table_$moderr fixed bin (35) external; dcl error_table_$noentry fixed bin (35) external; dcl error_table_$no_message fixed bin (35) external; dcl error_table_$root fixed bin (35) ext; dcl error_table_$rqover fixed bin (35) external; dcl (cleanup, no_write_permission, program_interrupt, record_quota_overflow) condition; dcl (addr, bin, collate, divide, fixed, index, length, min, null) builtin; dcl (rel, reverse, rtrim, search, size, substr, translate, unspec, verify) builtin; /* */ mail_format_ptr = null; on condition (cleanup) call mail_cleanup; command = "mail"; call cu_$arg_count (arg_count); buffer = ""; path_sw = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, ap, al, code); if substr (arg, 1, 1) = "-" then if arg = "-brief" | arg = "-bf" then brief = "1"b; else if arg = "-header" | arg = "-he" then head_mode = "1"b; else if arg = "-match" then do; dont_print_count = "1"b; i = i + 1; if i>arg_count then do; call com_err_ (0, command, "No value specified for -match"); return; end; call cu_$arg_ptr (i, ap, al, code); j = index (arg, "."); if j = 0 then match_person = arg; else do; match_person = substr (arg, 1, j-1); match_project = substr (arg, j+1); end; end; else if arg = "-exclude" | arg = "-ex" then do; dont_print_count = "1"b; i = i + 1; if i>arg_count then do; call com_err_ (0, command, "No value specified for -exclude"); return; end; call cu_$arg_ptr (i, ap, al, code); j = index (arg, "."); if j = 0 then exclude_person = arg; else do; exclude_person = substr (arg, 1, j-1); exclude_project = substr (arg, j+1); end; end; else if arg = "-acknowledge" | arg = "-ack" then go to SEND; else if arg = "-notify" | arg = "-nt" then go to SEND; else if arg = "-no_notify" | arg = "-nnt" then go to SEND; else if arg = "-pathname" | arg = "-pn" then do; if buffer ^= "" then go to SEND; i = i+1; if i>arg_count then do; call com_err_ (0, command, "No value specified for -pathname"); return; end; call cu_$arg_ptr (i, ap, al, code); buffer = arg; path_sw = "1"b; end; else do; call com_err_ (error_table_$badopt, command, "^a", arg); return; end; else if buffer ^= "" then go to SEND; else buffer = arg; end; if buffer = "" then do; /* Read from default mailbox */ READ: my_mbx = "1"b; bitcnt = 0; call user_info_$login_data (name, proj, "", anonymous); if anonymous = 1 then do; /* anonymous user */ dn = ">udd>" || rtrim (proj) || ">anonymous"; en = "anonymous.mbx"; end; else do; dn = ">udd>" || rtrim (proj) || ">" || name; en = rtrim (name) || ".mbx"; end; call mailbox_$open_if_full (dn, en, salvaged, count, mseg_index, code); if code = error_table_$noentry then do; /* Create a new mailbox */ on condition (record_quota_overflow) begin; call com_err_ (error_table_$rqover, command, "Unable to create default mailbox."); go to RETURN; end; call mailbox_$create (dn, en, code); if code ^= 0 then do; call com_err_ (code, command, "Unable to create default mailbox."); go to RETURN; end; revert condition (record_quota_overflow); call ioa_ ("^a>^a created. No mail.", dn, en); return; end; end; else do; /* Read from specified mailbox */ if buffer = ">" then do; code = error_table_$root; go to ERROR2; end; else if search (buffer, "<>") ^= 0 | path_sw then do; /* mbx pathname */ call expand_pathname_$add_suffix (buffer, "mbx", dn, en, code); if code ^= 0 then go to ERROR2; end; else do; /* Person.Project destination */ i = index (buffer, "."); if i = 0 then do; call com_err_ (0, command, "No project specified for ^a", buffer); return; end; call ioa_$rsnnl (">udd>^a>^a", dn, 168, substr (buffer, i+1), substr (buffer, 1, i-1)); en = substr (buffer, 1, i-1)||".mbx"; end; call mailbox_$open_if_full (dn, en, salvaged, count, mseg_index, code); end; if code ^= 0 & (code ^= error_table_$moderr | mseg_index = 0) then go to ERROR1; if salvaged then do; if my_mbx then call mailbox_$check_salv_bit_index (mseg_index, "1"b, salvaged, code); call ioa_ ("Mailbox ^a^[>^]^a has been salvaged since mail was last read. Messages may have been lost.", dn, dn ^= ">", en); end; if code = 0 then do; if count = 0 then do; if ^brief then call ioa_ ("No mail."); go to CLOSE; end; if count>1 then s = "s"; /* plural */ if ^dont_print_count then call ioa_ ("^d message^a.", count, s); if brief then go to CLOSE; end; areap = get_system_free_area_ (); argp = addr (mseg_return_args); call mailbox_$read_index (mseg_index, areap, "0"b, argp, code); /* read earliest message first */ if code ^= 0 then if code = error_table_$no_message then do; if ^brief then call ioa_ ("No mail."); go to CLOSE; end; else if code = error_table_$moderr then own = "1"b; else go to ERROR1; if own then do; call mailbox_$own_read_index (mseg_index, areap, "0"b, argp, code); if code ^= 0 then if code = error_table_$no_message then do; if ^brief then call ioa_ ("You have no messages in ^a^[>^]^a.", dn, dn ^= ">", en); go to CLOSE; end; else go to ERROR1; else if brief then do; call ioa_ ("You have messages in ^a^[>^]^a", dn, dn ^= ">", en); go to CLOSE; end; else call ioa_ ("^/Your messages:^/"); end; printing = "1"b; on condition (program_interrupt) begin; /* pi turns off printing */ printing = "0"b; go to REMEMBER; end; last_type = mail_type; /* initialize some variables */ last_sender, last_date = ""; last_time = 0; five_minutes = (3*10**8)* (2**18); idp, stack_ptr = addr (node_space); idp -> stack_bits = "0"b; do count = 1 by 1 while (code = 0); /* if a message is deleted while in this loop, all messages after it won't get printed. They will appear with next "mail". */ mail_format_ptr = msg_ptr; if ^printing then go to REMEMBER; clock = substr (id, 19, 54); unspec (time) = clock; call date_time_ (bin (clock, 71), atime); if lines ^= 1 then s = "s"; else s = ""; i = index (mseg_return_args.sender_id, " "); /* remove instance tag */ if i = 0 then i = 33; sender = substr (mseg_return_args.sender_id, 1, i-3); j = index (sender, "."); if exclude_person = "*" | exclude_person = substr (sender, 1, j-1) then go to RNEXT; if exclude_project = "*" | exclude_project = substr (sender, j+1) then go to RNEXT; if match_person ^= "*" & match_person ^= substr (sender, 1, j-1) then go to RNEXT; if match_project ^= "*" & match_project ^= substr (sender, j+1) then go to RNEXT; if head_mode then nlx = ""; else nlx = newline; if mail_format.wakeup then do; /* interractive message */ if last_type = mail_type then do; call ioa_ (""); last_sender = ""; end; if sender = last_sender & sent_from = last_sent_from & ^head_mode then do; if time-last_time>five_minutes then if substr (atime, 1, 8) ^= last_date then call ioa_$nnl ("=:(^a) ", atime); else call ioa_$nnl ("=:(^a) ", substr (atime, index (atime, ".")-4, 6)); else call ioa_$nnl ("=: "); end; else if sent_from = "" | sent_from = sender | sent_from = substr (sender, 1, length (sender)-index (reverse (sender), ".")) then call ioa_ ("^aMessage from ^a ^a:", nlx, sender, atime); else call ioa_ ("^aMessage from ^a (^a) ^a:", nlx, sender, rtrim (canon (rtrim (sent_from), length (rtrim (sent_from)))), atime); last_type = interactive; last_sender = sender; last_sent_from = sent_from; last_time = time; last_date = substr (atime, 1, 8); end; else do; last_type = mail_type; if sent_from = "" | sent_from = sender | sent_from = substr (sender, 1, length (sender)-index (reverse (sender), ".")) then call ioa_ ("^a^d) From: ^a ^a^[ (^d line^a)^;^s^s^]^a", nlx, count, sender, atime, (lines > 0), lines, s, nlx); else call ioa_ ("^a^d) From: ^a (^a) ^a^[ (^d line^a)^;^2s^]^a", nlx, count, rtrim (canon (rtrim (sent_from), length (rtrim (sent_from)))), sender, atime, (lines > 0), lines, s, nlx); end; /* Print the message */ if ^head_mode then do; i = 1; do while (i <= mail_format.text_len); j = min (mail_format.text_len-i+1, length (buffer)); buffer = rtrim (canon (substr (mail_format.text, i, j), length (substr (mail_format.text, i, j)))); call iox_$put_chars (iox_$user_output, addr (buffer), j, code); i = i+j; end; if substr (buffer, j, 1) ^= newline then call ioa_ (""); /* Acknowledge the message */ if mail_format.acknowledge then do; send_mail_info.version = 1; send_mail_info.from = ""; send_mail_info.wakeup = "1"b; send_mail_info.mbz1 = "0"b; send_mail_info.always_add = "1"b; send_mail_info.never_add = "0"b; send_mail_info.mbz2 = "0"b; send_mail_info.acknowledge = "0"b; send_mail_info.mbz = "0"b; clock = substr (mseg_return_args.id, 19, 54); unspec (time) = clock; call date_time_ (bin (clock, 71), atime); i = length (mseg_return_args.sender_id)+1-verify (reverse (mseg_return_args.sender_id), " "); call send_mail_ (substr (mseg_return_args.sender_id, 1, i-2), "Acknowledge message of "||atime, addr (send_mail_info), code); mail_format.acknowledge = "0"b; /* turn off acknowledge bit in message */ call mailbox_$update_message_index (mseg_index, 36 * (fixed (rel (addr (mail_format.text)))-fixed (rel (addr (mail_format.version)))), mseg_return_args.id, mseg_return_args.msg_ptr, code); end; end; /* Remember to delete later */ REMEMBER: if ^head_mode then do; call get_id_node; idp -> id_node.next = node_ptr; idp = node_ptr; idp -> id_node.next = null; idp -> id_node.delete_id = id; end; /* Read the next message */ RNEXT: free mail_format in (area); if own then call mailbox_$own_incremental_read_index (mseg_index, areap, "01"b, id, argp, code); else call mailbox_$incremental_read_index (mseg_index, areap, "01"b, id, argp, code); end; revert condition (program_interrupt); on condition (program_interrupt) go to QUERY; if code ^= error_table_$no_message then go to ERROR1; QUERY: if node_index = 0 then answer = "no"; else call command_query_ (addr (query_info), answer, command, "Delete?"); revert condition (program_interrupt); if answer ^= "yes" then go to CLOSE; count = 0; idp = addr (node_space); do while (idp ^= null); count = count+1; call mailbox_$delete_index (mseg_index, idp -> id_node.delete_id, code); if code ^= 0 then do; call com_err_ (code, command, "Message ^d not deleted.", count); code = 0; end; idp = idp -> id_node.next; end; go to CLOSE; /* */ /* Send mail */ SEND: notify_sw = "1"b; do i = 1 to arg_count; call cu_$arg_ptr (i, ap, al, code); if substr (arg, 1, 1) = "-" then /* look for control arguments */ if arg = "-acknowledge" | arg = "-ack" then acknowledge = "1"b; else if arg = "-notify" | arg = "-nt" then notify_sw = "1"b; else if arg = "-no_notify" | arg = "-nnt" then notify_sw = "0"b; else if arg ^= "-pathname" & arg ^= "-pn" then do; call com_err_ (error_table_$badopt, "mail", "^a", arg); return; end; end; on condition (record_quota_overflow) begin; /* from adding a message */ call com_err_ (error_table_$rqover, command, "Unable to add message to mailbox ^a^[>^]^a", dn, dn ^= ">", en); call save; go to RETURN; end; argno = 1; GET_PATH: call cu_$arg_ptr (argno, ap, al, code); argno = argno+1; if substr (arg, 1, 1) = "-" then go to GET_PATH; buffer = arg; if buffer = ">" then do; code = error_table_$root; go to ERROR2; end; text_length = 0; mail_format_ptr = null; call user_info_ (sender_name); SEND_LOOP: call cu_$arg_ptr (argno, ap, al, code); if code ^= 0 then do; /* Normal exit - no more destinations */ CLEANUP: call mail_cleanup; return; end; if substr (arg, 1, 1) = "-" then if arg = "-pathname" | arg = "-pn" then do; argno = argno + 1; call cu_$arg_ptr (argno, ap, al, code); if code ^= 0 then do; call com_err_ (0, command, "No value specified for -pathname"); return; end; call expand_pathname_$add_suffix (arg, "mbx", dn, en, code); if code ^= 0 then do; call com_err_ (code, command, "^a", arg); return; end; go to OPEN; end; else do; argno = argno+1; go to SEND_LOOP; end; i = index (arg, "."); if i ^= 0 then do; /* Person.Project destination */ argno = argno-1; name, vname = substr (arg, 1, i-1); proj, vproj = substr (arg, i+1); end; else do; name, vname = arg; GET_PROJ: call cu_$arg_ptr (argno+1, ap, al, code); if code ^= 0 then do; NO_PROJ: call com_err_ (0, command, "No project name specified for ^a.", vname); call save; return; end; if substr (arg, 1, 1) = "-" then if arg = "-pathname" | arg = "-pn" then go to NO_PROJ; else do; argno = argno+1; go to GET_PROJ; end; proj, vproj = arg; /* project id for concatenating */ end; en = vname || ".mbx"; dn = ">udd>" || vproj || ">" || vname; OPEN: call mailbox_$open (dn, en, mseg_index, code); /* get index of mailbox */ if code ^= 0 then do; call com_err_ (code, command, "^a^[>^]^a", dn, dn ^= ">", en); call save; go to NEXT; end; else do; call mailbox_$get_mode_index (mseg_index, exmode, code); /* get effective access to mailbox */ if ^substr (exmode, 1, 1) then do; /* no "a" access */ call com_err_ (0, command, "Insufficient access to send to ^a^[>^]^a", dn, dn ^= ">", en); call save; go to NEXT; end; end; if ^got_input then do; /* copy the message in once */ areap = get_system_free_area_ (); nlines = 0; if buffer = "*" then do; /* console input */ console = "1"b; got_input = "1"b; segp = addr (page); on condition (program_interrupt) begin; /* pi saves what is typed so far and quits */ call save; go to CLOSE; end; call ioa_ ("Input:"); more = "1"b; do while (more); call iox_$get_line (iox_$user_input, addr (buffer), 168, j, code); if code ^= 0 then if code ^= error_table_$long_record then do; call save; buffer = "user_input"; go to ERROR2; end; if j = 2 & substr (buffer, 1, 1) = "." then more = "0"b; /* dot ends input mode */ else do; if text_length+j>4096 then do; call com_err_ (0, command, "Message cannot be longer than 1 record."); call save; return; end; if code ^= error_table_$long_record then nlines = nlines + 1; substr (segp -> segment, text_length+1, j) = substr (buffer, 1, j); /* copy the line in */ text_length = text_length+j; end; end; revert condition (program_interrupt); if nlines = 0 then return; bitcnt = text_length*9; end; else do; /* input is a segment */ got_input = "1"b; call expand_pathname_ (rtrim (buffer), dn, en, code); if code ^= 0 then go to ERROR2; call hcs_$initiate_count (dn, en, "", bitcnt, 1, segp, code); if segp = null then go to ERROR1; seg_initiated = "1"b; call hcs_$fs_get_mode (segp, mode, code); /* see if access to read */ if mode<1000b then if code = 0 then do; call com_err_ (0, command, "Need ""r"" access to ^a^[>^]^a", dn, dn ^= ">", en); call hcs_$terminate_noname (segp, code); go to CLOSE; end; text_length = divide (bitcnt+8, 9, 17, 0); chars = text_length; if text_length>4096 then do; call com_err_ (0, command, "Message cannot be longer than 1 record."); go to CLOSE; end; count = 1; NL_LOOP: i = index (substr (segp -> segment, count, chars), newline); if i>0 then do; count = count+i; chars = chars-i; nlines = nlines+1; /* count newlines in input segment */ go to NL_LOOP; end; end; end; allocate mail_format in (area) set (mail_format_ptr); header_length = size (mail_format)-divide (text_length, 4, 17, 0); mail_format.version = MAIL_FORMAT_VERSION_4; mail_format.sent_from = sender_name; /* login name */ mail_format.lines = nlines; mail_format.acknowledge = acknowledge; mail_format.wakeup, mail_format.urgent, mail_format.seen, mail_format.others = "0"b; mail_format.text = substr (segp -> segment, 1, text_length); msg_bitcnt = bitcnt+36*header_length; /* total bit count includes header */ call mailbox_$add_index (mseg_index, mail_format_ptr, msg_bitcnt, id, code); /* try to add the message */ if code ^= 0 then if code = error_table_$bad_segment then go to ERROR1; else do; call com_err_ (code, command, "Unable to add message to mailbox ^a^[>^]^a", dn, dn ^= ">", en); call save; end; else if notify_sw then call send_message_$notify_mail (name, proj, code); /* send notification */ NEXT: argno = argno+2; /* on to the next pair */ call mailbox_$close (mseg_index, code); go to SEND_LOOP; /* */ /* save a message in working_dir>unsent_mail */ save: proc; if saved then return; /* do not save twice */ if ^console | ^got_input then return; if text_length = 0 then return; saved = "1"b; dn = get_wdir_ (); on condition (record_quota_overflow) begin; /* from unsent_mail */ call hcs_$delentry_file (dn, "unsent_mail", code); if ^pdir_flag then go to TRY_PDIR; call com_err_ (error_table_$rqover, command, "Unable to save message in unsent_mail."); go to CLEANUP; end; CREATE: call hcs_$make_seg (dn, "unsent_mail", "", 1011b, mbxp, code); if mbxp = null then do; if ^pdir_flag then go to TRY_PDIR; call com_err_ (code, command, "Unable to save message in unsent_mail."); go to CLOSE; end; on condition (no_write_permission) begin; if ^pdir_flag then go to TRY_PDIR; end; substr (mbxp -> segment, 1, text_length) = substr (segp -> segment, 1, text_length); bitcnt = text_length*9; call hcs_$set_bc_seg (mbxp, bitcnt, code); if pdir_flag then call ioa_ ("Text was saved in unsent_mail in process directory."); else call ioa_ ("Text was saved in unsent_mail."); return; TRY_PDIR: pdir_flag = "1"b; dn = get_pdir_ (); go to CREATE; end save; /* */ ERROR1: if code = error_table_$bad_segment then do; call com_err_ (code, command, "^a^[>^]^a^/Mailbox has been salvaged. Try again.", dn, dn ^= ">", en); call save; end; else call com_err_ (code, command, "^a^[>^]^a", dn, dn ^= ">", en); go to CLOSE; ERROR2: call com_err_ (code, command, "^a", buffer); CLOSE: if ^my_mbx & mseg_index ^= 0 then call mailbox_$close (mseg_index, code); if seg_initiated then call hcs_$terminate_noname (segp, code); RETURN: return; /* This procedure removes control characters (except backspace, tab, red ribbon shift, and black ribbon shift) and canonicalizes strings to prevent backspacing past the front of the string. */ canon: procedure (P_string, P_string_len) returns (char (*)); dcl P_string char (*) parm; dcl P_string_len fixed bin (21) parm; dcl output_string char (P_string_len); P_string = translate (P_string, alphabet); if index (P_string, BS) ^= 0 then do; output_string = ""; call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0)); return (output_string); end; else return (P_string); end canon; get_id_node: proc; node_index = node_index+1; if node_index>24 then do; /* allocate another block of 24 */ call cu_$grow_stack_frame (96, stack_ptr, code); stack_bits = "0"b; node_index = 1; end; node_ptr = addr (node (node_index)); end get_id_node; mail_cleanup: proc; if mail_format_ptr ^= null then free mail_format in (area); if mbxp ^= null then call hcs_$terminate_noname (mbxp, code); if ^my_mbx & mseg_index ^= 0 then call mailbox_$close (mseg_index, code); if seg_initiated then call hcs_$terminate_noname (segp, code); end mail_cleanup; end mail;  message_facility_.pl1 05/04/88 0827.0rew 05/04/88 0824.7 647766 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This subroutine is the heart of the Multics message facility. */ /* This replaces the Multics message facility written 12/01/75 by Steve Herbst. */ /****^ HISTORY COMMENTS: 1) change(84-05-10,Lippard), approve(), audit(), install(): Written by Jim Lippard. 2) change(84-11-16,Lippard), approve(), audit(), install(): Modified to prevent messages received from getting message numbers lower than those already in the mailbox. 3) change(84-11-27,Lippard), approve(), audit(), install(): Modified to fix the last fix correctly, to only print "You have N messages" in the alarm handler when a call string is NOT being used, and to make alarms work. 4) change(84-12-18,Lippard), approve(), audit(), install(): Modified to make message_facility_$send_message do something reasonable with error_table_$no_info. 5) change(85-01-11,Lippard), approve(), audit(), install(): Modified to make entry points take a message_id instead of an array index to prevent internal message arrays and applications' arrays from getting out of synch. 6) change(85-01-23,Lippard), approve(), audit(), install(): Modified to fix code calling mlr_. 7) change(85-01-30,Lippard), approve(), audit(), install(): Modified to speed up message selection by using a binary search. 8) change(85-03-26,Lippard), approve(), audit(), install(): Modified to speed up create_message_array and compact_message_array. 9) change(85-04-16,Lippard), approve(), audit(), install(): Modified to properly set the last message number when a new message is received. 10) change(85-05-31,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to initialize everything in the msg_facility_mailbox structure before any possible aborting/freeing takes place. 11) change(85-09-02,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to only send acknowledgements when the user has d permission on the mailbox. 12) change(86-04-23,Lippard), approve(86-05-27,MCR7418), audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080): Modified to make get_msg_array_ptr only call create_message_array when necessary. 13) change(86-06-04,Lippard), approve(86-06-24,MCR7432), audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080): Modified to properly zero fields in mail_format when sending messages. 14) change(86-06-05,Lippard), approve(86-06-24,MCR7437), audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080): Modified to correctly figure out when to use mailbox_$own_xxx entries. 15) change(86-08-06,Lippard), approve(87-03-18,MECR0001), audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002): Modified to check for unseen messages in wakeup processor. 16) change(87-01-29,Lippard), approve(87-03-18,MECR0001), audit(87-03-12,Fawcett), install(87-03-19,MR12.1-1002): Modified to strip control characters from message comment field. 17) change(87-05-08,Lippard), approve(87-04-20,MCR7669), audit(87-05-11,Fawcett), install(88-05-04,MR12.2-1045): Formal installation to close out MECR0001 and to use the permanent seen switches in the mailbox when access allows. 18) change(88-03-31,Lippard), approve(88-04-18,MCR7876), audit(88-04-26,Parisek), install(88-05-04,MR12.2-1045): Changed wakeup_processor to (a) stop setting P_code, which is not a parameter to that procedure and (b) check for error_table_$seg_unknown from mailbox_$get_mode_index. Also changed calls to ioa_$rsnnl to use the returned length correctly. END HISTORY COMMENTS */ message_facility_: procedure options (variable); return; /* not an entry */ dcl (P_msgf_mbx_ptr, P_next_msgf_mbx_ptr) ptr parm; dcl (P_dname, P_ename, P_message) char (*) parm; dcl P_access_class bit (72) aligned; dcl P_default_mbx bit (1) aligned parm; dcl P_flags bit (*) parm; dcl P_message_id bit (72) aligned parm; dcl P_prefix char (32) varying parm; dcl (P_short_prefix, P_short_format) bit (1) aligned parm; dcl P_handler entry variable parm; dcl P_info_ptr ptr parm; dcl P_time fixed bin (71) parm; dcl P_area_ptr ptr; dcl P_msg_array_ptr ptr parm; dcl P_n_messages fixed bin parm; dcl P_iocb_ptr ptr; dcl P_code fixed bin (35) parm; dcl access_class bit (1) aligned; dcl access_mode bit (36) aligned; dcl allow_switch bit (36) aligned; dcl array_length fixed bin (21); dcl authorization bit (72) aligned; dcl auth_string char (170); dcl call_string char (512) based (P_info_ptr); dcl change_state bit (1) aligned; dcl command_line char (2000); dcl count fixed bin; dcl current_message_index fixed bin; dcl d_permission bit (1) aligned; dcl default_dname char (168); dcl default_ename char (32); dcl default_uid bit (36) aligned; dcl destination_string char (array_length) based (destination_string_ptr); dcl destination_string_ptr ptr; dcl dname char (168); dcl ename char (32); dcl wakeup_flags bit (5) aligned; dcl full_name char (32) internal static init (""); dcl hold_this_message bit (1) aligned; dcl hold_this_notification bit (1) aligned; dcl iocb_ptr ptr; dcl last_index fixed bin; dcl last_message_set bit (1) aligned; dcl last_msg_time char (24) internal static init (""); dcl last_sender char (120) internal static init (""); dcl last_time fixed bin (71) internal static init (0); dcl mbx_index fixed bin; dcl message char (47); dcl message_bit_count fixed bin; dcl message_id bit (72) aligned; dcl message_ident char (200) varying; dcl message_index fixed bin; dcl message_sender char (120); dcl own bit (1) aligned; dcl person char (22) internal static init (""); dcl project char (9) internal static init (""); dcl person_id char (22); dcl project_id char (9); dcl login_name char (32); dcl seen_switch_flags bit (3) aligned; dcl short bit (1) aligned; dcl source_string char (array_length) based (source_string_ptr); dcl source_string_ptr ptr; dcl tag char (10) var; dcl uid bit (36) aligned; dcl use_call_string bit (1) aligned; dcl date_time fixed bin (71); dcl msg_date_time char (24); dcl current_date_time char (24); dcl freed_msgf_mbx_ptr ptr; dcl next_msgf_mbx_ptr ptr; dcl static_msgf_mbx_ptr ptr internal static init (null ()); dcl area_ptr ptr static init (null ()); dcl sys_area area (65560) based (area_ptr); dcl user_area_ptr ptr; dcl user_area area based (user_area_ptr); dcl 1 internal_msg_array (msg_facility_mailbox.n_elements) aligned based (msg_facility_mailbox.messages_ptr) like msg_array; dcl 1 local_lmi aligned like last_message_info; dcl 1 local_mi aligned like message_info; dcl 1 local_mra aligned like mseg_return_args; dcl 1 local_pf unaligned like msg_print_flags based (local_pf_ptr); dcl local_pf_ptr ptr; dcl 1 local_smi aligned like send_mail_info based (local_smi_ptr); dcl local_smi_ptr ptr; dcl new_message_number fixed bin; dcl found bit (1) aligned; dcl retried bit (1) aligned; dcl (idx, jdx) fixed bin; dcl code fixed bin (35); dcl aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned) reducible; dcl error_table_$bad_segment fixed bin (35) ext static; dcl error_table_$bad_subr_arg fixed bin (35) ext static; dcl error_table_$messages_off fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$no_info fixed bin (35) ext static; dcl error_table_$no_message fixed bin (35) ext static; dcl error_table_$rqover fixed bin (35) ext static; dcl error_table_$seg_unknown fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl (addr, after, before, clock, collate, divide, fixed, index, length, max, min, null, rel, rtrim, size, string, substr, translate, unspec) builtin; dcl (cleanup, record_quota_overflow) condition; dcl canonicalize_ entry (ptr, fixed bin (21), ptr, fixed bin (21), fixed bin (35)); dcl convert_access_class_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl get_authorization_ entry () returns (bit (72) aligned) reducible; dcl get_system_free_area_ entry () returns (ptr); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$ioa_switch_nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$user_io ptr ext static; dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl mailbox_$accept_wakeups_index entry (fixed bin, fixed bin (71), bit (36) aligned, fixed bin (35)); dcl mailbox_$close entry (fixed bin, fixed bin (35)); dcl mailbox_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35)); dcl mailbox_$get_mode_index entry (fixed bin, bit (36) aligned, fixed bin (35)); dcl mailbox_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35)); dcl mailbox_$incremental_read_index entry (fixed bin, ptr, bit (2) aligned, bit (72) aligned, ptr, fixed bin (35)); dcl mailbox_$open entry (char (*), char (*), fixed bin, fixed bin (35)); dcl mailbox_$own_incremental_read_index entry (fixed bin, ptr, bit (2) aligned, bit (72) aligned, ptr, fixed bin (35)); dcl mailbox_$own_read_index entry (fixed bin, ptr, bit (1) aligned, ptr, fixed bin (35)); dcl mailbox_$read_index entry (fixed bin, ptr, bit (1) aligned, ptr, fixed bin (35)); dcl mailbox_$update_message_index entry (fixed bin, fixed bin, bit (72) aligned, ptr, fixed bin (35)); dcl mailbox_$wakeup_add_index entry (fixed bin, ptr, fixed bin, bit (36) aligned, bit (72) aligned, fixed bin (35)); dcl mailbox_$wakeup_aim_add_index entry (fixed bin, ptr, fixed bin, bit (36) aligned, bit (72) aligned, bit (72) aligned, fixed bin (35)); dcl message_facility_$alarm_processor entry (ptr); dcl message_facility_$wakeup_processor entry (ptr); dcl message_facility_$default_alarm_handler entry (ptr, ptr); dcl message_facility_$default_wakeup_handler entry (ptr, ptr); dcl message_facility_$delete_message entry (ptr, bit (72) aligned, fixed bin (35)); dcl message_facility_$free_msgf_mbx_ptr entry (ptr, fixed bin (35)); dcl message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35)); dcl message_facility_$print_message entry (ptr, ptr, bit (72) aligned, ptr, fixed bin (35)); dcl message_facility_$read_message entry (ptr, bit (72) aligned, ptr, ptr, fixed bin (35)); dcl message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$set_seen_switch entry (ptr, bit (72) aligned, bit (*), fixed bin (35)); dcl mrl_ entry (ptr, fixed bin (21), ptr, fixed bin (21)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl sub_err_ entry options (variable); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)); dcl timer_manager_$reset_alarm_wakeup entry (fixed bin (71)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl value_$get entry () options (variable); dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); dcl ALPHABET char (256) init ((8)" " || " " || (4)" " || "" || (16)" " || substr (collate (), 33)); /* space, BSHT, space, RRSBRS, space, alphanumerics */ dcl FIVE_MINUTES fixed bin (71) internal static options (constant) init (300000000); dcl MSG_ARRAY_BLOCK_SIZE fixed bin internal static options (constant) init (100); dcl MSG_ARRAY_ELEMENT_LENGTH fixed bin internal static options (constant) init (16); /* four words, sixteen characters */ dcl NL char (1) aligned internal static options (constant) init (" "); dcl NLSPHT char (3) aligned internal static options (constant) init (" "); dcl BS char (1) aligned internal static options (constant) init (""); dcl PERMANENT_VALUES bit (36) aligned internal static options (constant) init ("200000000000"b3); dcl READ_CURRENT bit (2) aligned internal static options (constant) init ("00"b); dcl READ_FIRST bit (1) aligned internal static options (constant) init ("0"b); dcl READ_FORWARD bit (2) aligned internal static options (constant) init ("01"b); dcl RELATIVE_SECONDS bit (2) internal static options (constant) init ("11"b); /* This entry returns the next msg facility mailbox pointer in the chain. */ get_next_msgf_mbx_ptr: entry (P_msgf_mbx_ptr, P_next_msgf_mbx_ptr); msg_facility_mailbox_ptr = P_msgf_mbx_ptr; P_next_msgf_mbx_ptr = null (); if msg_facility_mailbox_ptr = null () then next_msgf_mbx_ptr = static_msgf_mbx_ptr; else next_msgf_mbx_ptr = msg_facility_mailbox.next_mbx_ptr; code = 1; do while (code ^= 0); msg_facility_mailbox_ptr = next_msgf_mbx_ptr; code = 0; if msg_facility_mailbox_ptr ^= null () then do; /* see if it's there and we have access */ call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; call message_facility_$free_msgf_mbx_ptr (msg_facility_mailbox_ptr, (0)); if P_msgf_mbx_ptr = null () then next_msgf_mbx_ptr = static_msgf_mbx_ptr; else next_msgf_mbx_ptr = P_msgf_mbx_ptr -> msg_facility_mailbox.next_mbx_ptr; end; end; end; P_next_msgf_mbx_ptr = next_msgf_mbx_ptr; return; /* get_next_msgf_mbx_ptr */ /* This entry returns a msg facility mailbox pointer for the specified mailbox. */ get_msgf_mbx_ptr: entry (P_dname, P_ename, P_msgf_mbx_ptr, P_code); dname = P_dname; ename = P_ename; P_msgf_mbx_ptr = null (); P_code = 0; call mailbox_$get_uid_file (dname, ename, uid, code); if code ^= 0 then do; P_code = code; return; end; msg_facility_mailbox_ptr = static_msgf_mbx_ptr; found = FALSE; do while ((msg_facility_mailbox_ptr ^= null ()) & ^found); if msg_facility_mailbox.uid = uid then found = TRUE; else msg_facility_mailbox_ptr = msg_facility_mailbox.next_mbx_ptr; end; if ^found then do; /* add a new one, at the beginning of the list */ if area_ptr = null () then area_ptr = get_system_free_area_ (); allocate msg_facility_mailbox set (msg_facility_mailbox_ptr) in (sys_area); msg_facility_mailbox.next_mbx_ptr = static_msgf_mbx_ptr; static_msgf_mbx_ptr = msg_facility_mailbox_ptr; /* initialize the structure */ msg_facility_mailbox.version = MSG_FACILITY_MAILBOX_VERSION_1; msg_facility_mailbox.dname = dname; msg_facility_mailbox.ename = ename; msg_facility_mailbox.uid = uid; call user_info_$whoami (person, project, ""); default_dname = ">udd>" || rtrim (project) || ">" || rtrim (person); default_ename = rtrim (person) || ".mbx"; call mailbox_$get_uid_file (default_dname, default_ename, default_uid, (0)); if uid = default_uid then msg_facility_mailbox.default_mbx = TRUE; else msg_facility_mailbox.default_mbx = FALSE; msg_facility_mailbox.event_channel = 0; string (msg_facility_mailbox.wakeup_flags) = ""b; msg_facility_mailbox.mbz = ""b; msg_facility_mailbox.short_format = FALSE; msg_facility_mailbox.prefix = ""; msg_facility_mailbox.short_prefix = FALSE; msg_facility_mailbox.alarm_time = 0; msg_facility_mailbox.alarm_event_channel = 0; msg_facility_mailbox.last_message_ptr = null (); msg_facility_mailbox.last_id = ""b; msg_facility_mailbox.last_message_number = 0; msg_facility_mailbox.highest_message = 0; msg_facility_mailbox.messages_ptr = null (); msg_facility_mailbox.n_elements = 0; msg_facility_mailbox.n_messages = 0; msg_facility_mailbox.msg_array_compacted = TRUE; msg_facility_mailbox.msg_array_updated = FALSE; msg_facility_mailbox.wakeup_handler = message_facility_$default_wakeup_handler; msg_facility_mailbox.wakeup_info_ptr = null (); msg_facility_mailbox.alarm_handler = message_facility_$default_alarm_handler; msg_facility_mailbox.alarm_info_ptr = null (); /* We do this last so that everything is initialized properly in case we have to free the structure. */ call mailbox_$open (dname, ename, msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; return; end; end; else do; /* see if mailbox is still there */ call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; call message_facility_$free_msgf_mbx_ptr (msg_facility_mailbox_ptr, (0)); return; end; end; P_msgf_mbx_ptr = msg_facility_mailbox_ptr; return; /* get_msgf_mbx_ptr */ /* This entry makes a mailbox unknown to the message facility. */ free_msgf_mbx_ptr: entry (P_msgf_mbx_ptr, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; call mailbox_$close (msg_facility_mailbox.index, (0)); freed_msgf_mbx_ptr = msg_facility_mailbox_ptr; msg_facility_mailbox_ptr = static_msgf_mbx_ptr; if P_msgf_mbx_ptr = static_msgf_mbx_ptr then do; /* free first mailbox in list */ msg_facility_mailbox_ptr = static_msgf_mbx_ptr; static_msgf_mbx_ptr = msg_facility_mailbox.next_mbx_ptr; end; else do; /* set msg_facility_mailbox_ptr to point to mbx in list just BEFORE the one we're freeing */ found = FALSE; do msg_facility_mailbox_ptr = static_msgf_mbx_ptr repeat (msg_facility_mailbox.next_mbx_ptr) while (msg_facility_mailbox.next_mbx_ptr ^= null () & ^found); if msg_facility_mailbox.next_mbx_ptr = freed_msgf_mbx_ptr then found = TRUE; end; if msg_facility_mailbox.next_mbx_ptr = null () then do; /* this msgf structure isn't in our list! */ P_code = error_table_$unimplemented_version; return; end; end; P_msgf_mbx_ptr = null (); msg_facility_mailbox.next_mbx_ptr = freed_msgf_mbx_ptr -> msg_facility_mailbox.next_mbx_ptr; msg_facility_mailbox_ptr = freed_msgf_mbx_ptr; /* reset alarm wakeups */ if msg_facility_mailbox.alarm_time > 0 then call timer_manager_$reset_alarm_wakeup (msg_facility_mailbox.alarm_event_channel); /* delete event channels */ if msg_facility_mailbox.alarm_event_channel ^= 0 then call ipc_$delete_ev_chn (msg_facility_mailbox.alarm_event_channel, (0)); if msg_facility_mailbox.event_channel ^= 0 then call ipc_$delete_ev_chn (msg_facility_mailbox.event_channel, (0)); /* free last message mail format structure */ if msg_facility_mailbox.last_message_ptr ^= null () then do; message_info_ptr = msg_facility_mailbox.last_message_ptr; if message_info.message_ptr ^= null () then free message_info.message_ptr -> mail_format in (sys_area); free message_info in (sys_area); end; /* free message array */ if msg_facility_mailbox.messages_ptr ^= null () then free internal_msg_array in (sys_area); free msg_facility_mailbox in (sys_area); return; /* free_msgf_mbx_ptr */ /* This entry returns the wakeup state for the specified mailbox. */ get_wakeup_state: entry (P_msgf_mbx_ptr, P_flags, P_code); P_flags = ""b; P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; P_flags = substr (string (msg_facility_mailbox.wakeup_flags), 1, 5); return; /* get_wakeup_state */ /* This entry sets the wakeup state for the specified mailbox. */ set_wakeup_state: entry (P_msgf_mbx_ptr, P_flags, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; wakeup_flags = P_flags; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if substr (wakeup_flags, 4, 2) = "00"b | substr (wakeup_flags, 4, 2) = "11"b then do; /* can't currently "unaccept" messages, 11 is undefined */ P_code = error_table_$bad_subr_arg; return; end; if msg_facility_mailbox.event_channel = 0 then do; call ipc_$create_ev_chn (msg_facility_mailbox.event_channel, code); if code ^= 0 then do; P_code = code; return; end; call ipc_$decl_ev_call_chn (msg_facility_mailbox.event_channel, message_facility_$wakeup_processor, msg_facility_mailbox_ptr, (1), code); if code ^= 0 then do; P_code = code; return; end; end; if wakeup_flags ^= string (msg_facility_mailbox.wakeup_flags) then change_state = TRUE; string (msg_facility_mailbox.wakeup_flags) = wakeup_flags; substr (allow_switch, 1, 1) = substr (msg_facility_mailbox.wakeup_state, 1, 1); substr (allow_switch, 2, 1) = substr (allow_switch, 1, 1); SET_WAKEUP_STATE: call mailbox_$accept_wakeups_index (msg_facility_mailbox.index, msg_facility_mailbox.event_channel, allow_switch, code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; return; end; go to SET_WAKEUP_STATE; end; else if code ^= 0 then do; P_code = code; return; end; if substr (allow_switch, 1, 1) = FALSE & change_state then msg_facility_mailbox.msg_array_updated = FALSE; return; /* set_wakeup_state */ /* This entry returns the pathname for the specified mailbox. */ get_mbx_path: entry (P_msgf_mbx_ptr, P_dname, P_ename, P_default_mbx, P_code); P_dname, P_ename = ""; P_default_mbx = ""b; P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; P_dname = msg_facility_mailbox.dname; P_ename = msg_facility_mailbox.ename; P_default_mbx = msg_facility_mailbox.default_mbx; return; /* get_mbx_path */ /* This entry returns the prefix information for the specified mailbox. */ get_prefix: entry (P_msgf_mbx_ptr, P_prefix, P_short_prefix, P_code); P_prefix = ""; P_short_prefix = ""b; P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; P_prefix = msg_facility_mailbox.prefix; P_short_prefix = msg_facility_mailbox.short_prefix; return; /* get_prefix */ /* This entry sets the prefix information for the specified mailbox. */ set_prefix: entry (P_msgf_mbx_ptr, P_prefix, P_short_prefix, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; msg_facility_mailbox.prefix = P_prefix; msg_facility_mailbox.short_prefix = P_short_prefix; return; /* set_prefix */ /* This entry returns the short format switch for the specified mailbox. */ get_message_format: entry (P_msgf_mbx_ptr, P_short_format, P_code); P_short_format = ""b; P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; P_short_format = msg_facility_mailbox.short_format; return; /* get_message_format */ /* This entry sets the short format switch for the specified mailbox. */ set_message_format: entry (P_msgf_mbx_ptr, P_short_format, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; msg_facility_mailbox.short_format = P_short_format; return; /* set_message_format */ /* This entry returns the alarm handler for the specified mailbox. */ get_alarm_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_time, P_code); P_info_ptr = null (); P_time = 0; P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; P_handler = msg_facility_mailbox.alarm_handler; P_info_ptr = msg_facility_mailbox.alarm_info_ptr; P_time = msg_facility_mailbox.alarm_time; return; /* get_alarm_handler */ /* This entry sets the alarm handler for the specified mailbox. */ set_alarm_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_time, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if msg_facility_mailbox.event_channel = 0 then do; P_code = error_table_$messages_off; return; end; msg_facility_mailbox.alarm_handler = P_handler; msg_facility_mailbox.alarm_info_ptr = P_info_ptr; msg_facility_mailbox.alarm_time = P_time; /* if alarm time is nonzero, turn on hold messages mode */ if msg_facility_mailbox.alarm_time ^= 0 then msg_facility_mailbox.hold_messages = TRUE; /* turn off any preexisting alarm */ if msg_facility_mailbox.alarm_event_channel ^= 0 then call timer_manager_$reset_alarm_wakeup (msg_facility_mailbox.alarm_event_channel); if msg_facility_mailbox.alarm_event_channel = 0 then do; call ipc_$create_ev_chn (msg_facility_mailbox.alarm_event_channel, code); if code ^= 0 then do; P_code = code; return; end; call ipc_$decl_ev_call_chn (msg_facility_mailbox.alarm_event_channel, message_facility_$alarm_processor, msg_facility_mailbox_ptr, (1), code); if code ^= 0 then do; P_code = code; return; end; end; if P_time ^= 0 then call timer_manager_$alarm_wakeup (msg_facility_mailbox.alarm_time, RELATIVE_SECONDS, msg_facility_mailbox.alarm_event_channel); return; /* set_alarm_handler */ /* This entry returns the wakeup handler for the specified mailbox. */ get_wakeup_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_code); P_info_ptr = null (); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; P_handler = msg_facility_mailbox.wakeup_handler; P_info_ptr = msg_facility_mailbox.wakeup_info_ptr; return; /* get_wakeup_handler */ /* This entry sets the wakeup handler for the specified mailbox. */ set_wakeup_handler: entry (P_msgf_mbx_ptr, P_handler, P_info_ptr, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if msg_facility_mailbox.event_channel = 0 then do; P_code = error_table_$messages_off; return; end; msg_facility_mailbox.wakeup_handler = P_handler; msg_facility_mailbox.wakeup_info_ptr = P_info_ptr; return; /* set_wakeup_handler */ /* This entry returns last message information for the specified mailbox. */ get_last_message_info: entry (P_msgf_mbx_ptr, P_info_ptr, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; last_message_info_ptr = P_info_ptr; if last_message_info.version ^= LAST_MESSAGE_INFO_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; last_message_info.last_message_ptr = msg_facility_mailbox.last_message_ptr; last_message_info.last_message_id = msg_facility_mailbox.last_id; last_message_info.last_message_number = msg_facility_mailbox.last_message_number; return; /* get_last_message_info */ /* This entry returns a pointer to the message array for the specified mailbox. */ get_msg_array_ptr: entry (P_msgf_mbx_ptr, P_area_ptr, P_msg_array_ptr, P_n_messages, P_code); P_msg_array_ptr = null (); P_n_messages = 0; P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; user_area_ptr = P_area_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if user_area_ptr = null () then user_area_ptr = get_system_free_area_ (); /* Determine which mailbox_ entry points to use. */ call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code); if code ^= 0 then do; P_code = code; return; end; own = ^substr (access_mode, 3, 1); /* Check to see if any new messages have arrived that we missed. */ CHECK_LAST_MESSAGE: if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_FORWARD, msg_facility_mailbox.last_id, addr (local_mra), code); else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_FORWARD, msg_facility_mailbox.last_id, addr (local_mra), code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; return; end; go to CHECK_LAST_MESSAGE; end; if code ^= error_table_$no_message then msg_facility_mailbox.msg_array_updated = FALSE; /* If the message array has already been created in the past and we are accepting messages, the message array is automatically kept up-to-date and there is no need to waste computrons going through the entire mailbox. (The above code takes care of the cases where we're losing wakeups, due to another user accepting messages out from under us or whatever.) */ if msg_facility_mailbox.wakeup_state = "10"b & msg_facility_mailbox.messages_ptr ^= null () & msg_facility_mailbox.msg_array_updated then do; if ^msg_facility_mailbox.msg_array_compacted then call compact_message_array; end; else do; call create_message_array; if code ^= 0 then P_code = code; end; n_messages = msg_facility_mailbox.n_messages; allocate msg_array in (user_area); array_length = MSG_ARRAY_ELEMENT_LENGTH * n_messages; destination_string_ptr = addr (msg_array (1)); source_string_ptr = addr (internal_msg_array (1)); destination_string = source_string; P_n_messages = n_messages; P_msg_array_ptr = msg_array_ptr; return; /* get_msg_array_ptr */ /* This entry returns the specified message from the specified mailbox. */ read_message: entry (P_msgf_mbx_ptr, P_message_id, P_area_ptr, P_info_ptr, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; message_id = P_message_id; message_info_ptr = P_info_ptr; user_area_ptr = P_area_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if message_info.version ^= MESSAGE_INFO_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if user_area_ptr = null () then user_area_ptr = get_system_free_area_ (); /* Determine which mailbox_ entry points to use. */ call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code); if code ^= 0 then do; P_code = code; return; end; own = ^substr (access_mode, 3, 1); READ_MESSAGE: if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_CURRENT, message_id, addr (local_mra), code); else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, user_area_ptr, READ_CURRENT, message_id, addr (local_mra), code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; return; end; go to READ_MESSAGE; end; /* If the message isn't found, our message array could be out of synch with the mailbox, so we need to call create_message_array in the next call to message_facility_$get_msg_array_ptr. */ if code = error_table_$no_message then msg_facility_mailbox.msg_array_updated = FALSE; if code ^= 0 then do; P_code = code; return; end; message_info.sender = local_mra.sender_id; message_info.message_ptr = local_mra.ms_ptr; message_info.authorization = local_mra.sender_authorization; return; /* read_message */ /* This entry sets the seen switch for the specified message in the specified mailbox. */ set_seen_switch: entry (P_msgf_mbx_ptr, P_message_id, P_flags, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; message_id = P_message_id; seen_switch_flags = P_flags; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; call get_message_index (message_id, message_index, code); if code ^= 0 then do; P_code = code; return; end; /* Determine which mailbox_ entry points to use. */ call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code); if code ^= 0 then do; P_code = code; return; end; own = ^substr (access_mode, 3, 1); SET_SEEN_SWITCH: if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT, message_id, addr (local_mra), code); else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT, message_id, addr (local_mra), code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; return; end; go to SET_SEEN_SWITCH; end; if code ^= 0 then do; P_code = code; return; end; mail_format_ptr = local_mra.ms_ptr; d_permission = substr (access_mode, 2, 1); if mail_format.acknowledge & d_permission then call send_acknowledgement; if substr (seen_switch_flags, 1, 1) then do; /* use defaults */ hold_this_message = msg_facility_mailbox.hold_messages; hold_this_notification = msg_facility_mailbox.hold_notifications; end; else do; /* use supplied args */ hold_this_message = substr (seen_switch_flags, 2, 1); hold_this_notification = substr (seen_switch_flags, 3, 1); end; /* set seen switch */ internal_msg_array.printed (message_index) = TRUE; if d_permission then do; mail_format.seen = TRUE; call mailbox_$update_message_index (msg_facility_mailbox.index, 36 * (fixed (rel (addr (mail_format.text))) - fixed (rel (addr (mail_format.version)))), message_id, local_mra.ms_ptr, (0)); end; found = FALSE; last_message_set = FALSE; last_index = 0; do idx = msg_facility_mailbox.n_elements to 1 by -1 while (^found); if internal_msg_array.message_id (idx) ^= ""b then do; found = TRUE; last_index = idx; end; end; if (message_index = last_index & message_id ^= msg_facility_mailbox.last_id) & found then do; /* set last message info */ last_message_set = TRUE; message_info_ptr = msg_facility_mailbox.last_message_ptr; if message_info_ptr ^= null () then do; mail_format_ptr = message_info.message_ptr; if mail_format_ptr ^= null () then free mail_format in (sys_area); free message_info in (sys_area); end; mail_format_ptr = local_mra.ms_ptr; allocate message_info in (sys_area); message_info.version = MESSAGE_INFO_VERSION_1; message_info.sender = local_mra.sender_id; message_info.message_ptr = local_mra.ms_ptr; message_info.authorization = local_mra.sender_authorization; msg_facility_mailbox.last_message_ptr = message_info_ptr; msg_facility_mailbox.last_id = message_id; msg_facility_mailbox.last_message_number = internal_msg_array.message_number (message_index); end; if d_permission & ((mail_format.notify & ^hold_this_notification) | (^mail_format.notify & ^hold_this_message)) then do; /* delete message */ call message_facility_$delete_message (msg_facility_mailbox_ptr, message_id, code); if code ^= 0 then do; P_code = code; if ^last_message_set then free mail_format in (sys_area); return; end; end; /* delete message */ if ^last_message_set then free mail_format in (sys_area); return; /* set_seen_switch */ /* This entry sends a message to the specified mailbox. */ send_message: entry (P_dname, P_ename, P_message, P_info_ptr, P_code); access_class = FALSE; go to SEND_COMMON; send_message_access_class: entry (P_dname, P_ename, P_message, P_info_ptr, P_access_class, P_code); access_class = TRUE; authorization = P_access_class; SEND_COMMON: P_code = 0; dname = P_dname; ename = P_ename; local_smi_ptr = P_info_ptr; on cleanup begin; if mbx_index ^= 0 then call mailbox_$close (mbx_index, (0)); end; call mailbox_$open (dname, ename, mbx_index, code); if code ^= 0 then do; P_code = code; return; end; if P_message = "" then text_length = 0; else text_length = length (rtrim (P_message)); message_bit_count = size (mail_format) * 36; begin; /* allocate message */ dcl mail_format_space bit (message_bit_count) aligned; dcl 1 local_mf aligned like mail_format based (local_mf_ptr); dcl local_mf_ptr ptr; local_mf_ptr = addr (mail_format_space); local_mf.text_len = text_length; local_mf.version = MAIL_FORMAT_VERSION_4; local_mf.sent_from = local_smi.sent_from; string (local_mf.switches) = ""b; local_mf.wakeup = local_smi.wakeup; local_mf.notify = local_smi.notify; local_mf.acknowledge = local_smi.acknowledge; local_mf.text = rtrim (P_message); local_mf.lines = 0; call get_person_and_project; if local_mf.sent_from = "" then local_mf.sent_from = person; else if local_mf.sent_from = person then local_mf.sent_from = full_name; idx = 1; count = 1; do while (idx ^= 0 & text_length ^= 0); idx = index (substr (P_message, count, text_length), NL); count = count + idx; text_length = text_length - idx; local_mf.lines = local_mf.lines + 1; end; on record_quota_overflow begin; P_code = error_table_$rqover; go to RETURN_FROM_SM; end; allow_switch = local_mf.wakeup || local_mf.urgent || local_smi.always_add || local_smi.never_add; retried = FALSE; RETRY: if ^access_class then call mailbox_$wakeup_add_index (mbx_index, addr (local_mf), message_bit_count, allow_switch, message_id, code); else call mailbox_$wakeup_aim_add_index (mbx_index, addr (local_mf), message_bit_count, allow_switch, authorization, message_id, code); if code = error_table_$bad_segment & ^retried then do; retried = TRUE; go to RETRY; end; /* error_table_$no_info means the message was delivered but the wakeup may not have been due to AIM. This statement will not be necessary if the primitives are changed to return a different error code in this case (e_t_$no_info from mailbox_$open IS an error, the message is not sent). */ else if code = error_table_$no_info then code = 0; P_code = code; end; RETURN_FROM_SM: call mailbox_$close (mbx_index, (0)); return; /* send_message */ /* This entry deletes a message from the specified mailbox. */ delete_message: entry (P_msgf_mbx_ptr, P_message_id, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; message_id = P_message_id; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; call get_message_index (message_id, message_index, code); if code ^= 0 then do; P_code = code; return; end; DELETE_MESSAGE: call mailbox_$delete_index (msg_facility_mailbox.index, message_id, code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then do; P_code = code; return; end; go to DELETE_MESSAGE; end; else if code ^= 0 then do; P_code = code; return; end; /* mark msg as deleted in message array */ internal_msg_array.message_id (message_index) = ""b; internal_msg_array.message_number (message_index) = 0; msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages - 1; msg_facility_mailbox.msg_array_compacted = FALSE; return; /* delete_message */ /* This entry prints a message. */ print_message: entry (P_msgf_mbx_ptr, P_iocb_ptr, P_message_id, P_info_ptr, P_code); P_code = 0; msg_facility_mailbox_ptr = P_msgf_mbx_ptr; iocb_ptr = P_iocb_ptr; message_id = P_message_id; local_pf_ptr = P_info_ptr; if msg_facility_mailbox.version ^= MSG_FACILITY_MAILBOX_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; if ^local_pf.print_last_message then do; call get_message_index (message_id, message_index, code); if code ^= 0 then do; P_code = code; return; end; mail_format_ptr = null (); local_mi.version = MESSAGE_INFO_VERSION_1; on cleanup begin; if mail_format_ptr ^= null () then free mail_format in (sys_area); end; call message_facility_$read_message (msg_facility_mailbox_ptr, message_id, area_ptr, addr (local_mi), code); if code ^= 0 then return; end; else do; /* use last message info */ local_lmi.version = LAST_MESSAGE_INFO_VERSION_1; call message_facility_$get_last_message_info (msg_facility_mailbox_ptr, addr (local_lmi), code); if code ^= 0 then do; P_code = code; return; end; if local_lmi.last_message_id = ""b then do; P_code = error_table_$no_message; return; end; message_info_ptr = local_lmi.last_message_ptr; local_mi = message_info; end; mail_format_ptr = local_mi.message_ptr; if ^local_pf.print_last_message then do; if internal_msg_array.message_number (message_index) ^= 0 then call ioa_$rsnnl ("^d) ", tag, (0), internal_msg_array.message_number (message_index)); else tag = ""; end; else do; if local_lmi.last_message_number ^= 0 then call ioa_$rsnnl ("^d) ", tag, (0), local_lmi.last_message_number); else tag = ""; end; /* print prefix, it may contain ioa_ controls */ if local_pf.print_prefix then call ioa_$ioa_switch_nnl (iocb_ptr, msg_facility_mailbox.prefix); message_ident = ""; if local_pf.print_ename then message_ident = rtrim (msg_facility_mailbox.ename) || " "; if local_pf.print_sender then do; /* create message sender string */ message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2); if mail_format.sent_from ^= before (local_mi.sender, ".") & rtrim (mail_format.sent_from) ^= "" then message_sender = rtrim (message_sender) || " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")"; authorization = get_authorization_ (); if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do; call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code); if auth_string = "" then auth_string = "system_low"; message_sender = rtrim (message_sender) || " at " || auth_string; end; if tag ^= "" then message_ident = message_ident || tag || rtrim (message_sender); else message_ident = message_ident || "From " || rtrim (message_sender); end; else message_ident = message_ident || tag || "="; if ^local_pf.print_last_message then date_time = fixed (substr (message_id, 19, 54), 71); else date_time = fixed (substr (local_lmi.last_message_id, 19, 54), 71); if local_pf.print_date_and_time then message_ident = message_ident || " " || date_time_$format ("date_time", date_time, "", ""); else if local_pf.print_time then message_ident = message_ident || " " || date_time_$format ("time", date_time, "", ""); call ioa_$ioa_switch_nnl (iocb_ptr, "^a: ^[^/^]^a^/", message_ident, (length (message_ident) > 16 & (length (message_ident) + mail_format.text_len > 80)), rtrim (canon (rtrim (mail_format.text), length (rtrim (mail_format.text))))); if ^local_pf.print_last_message then if mail_format_ptr ^= null () then free mail_format in (sys_area); return; /* print_message */ /* This entry is the processor for alarms. */ alarm_processor: entry (P_info_ptr); event_call_info_ptr = P_info_ptr; msg_facility_mailbox_ptr = event_call_info.data_ptr; call create_message_array; if code = error_table_$no_message then code = 0; if code ^= 0 then do; call sub_err_ (code, "alarm", ACTION_CANT_RESTART, null (), (0), "While updating message array for mailbox ^a.", pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename))); return; end; call msg_facility_mailbox.alarm_handler (msg_facility_mailbox_ptr, msg_facility_mailbox.alarm_info_ptr); if msg_facility_mailbox.alarm_time > 0 then call timer_manager_$alarm_wakeup (msg_facility_mailbox.alarm_time, RELATIVE_SECONDS, msg_facility_mailbox.alarm_event_channel); return; /* alarm_processor */ /* This entry is the processor for wakeups. */ wakeup_processor: entry (P_info_ptr); event_call_info_ptr = P_info_ptr; msg_facility_mailbox_ptr = event_call_info.data_ptr; /* Determine which mailbox_ entry points to use. */ WAKEUP_GET_MODE_INDEX: call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then return; go to WAKEUP_GET_MODE_INDEX; end; else if code ^= 0 then return; else own = ^substr (access_mode, 3, 1); /* Check to see if any new messages have arrived that we missed. */ WAKEUP_CHECK_LAST_MESSAGE: if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD, msg_facility_mailbox.last_id, addr (local_mra), code); else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD, msg_facility_mailbox.last_id, addr (local_mra), code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then return; go to WAKEUP_CHECK_LAST_MESSAGE; end; if code ^= error_table_$no_message then msg_facility_mailbox.msg_array_updated = FALSE; if ^msg_facility_mailbox.msg_array_updated then call create_message_array; else if ^msg_facility_mailbox.msg_array_compacted then call compact_message_array; message_id = unspec (event_call_info.message); /* Update last message info, do not mark message seen. */ PROCESSOR_READ: if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT, message_id, addr (local_mra), code); else call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_CURRENT, message_id, addr (local_mra), code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then return; go to PROCESSOR_READ; end; if code = error_table_$no_message then return; /* no big deal. */ if code ^= 0 then do; call sub_err_ (code, "wakeup", ACTION_CANT_RESTART, null (), (0), "While reading message from mailbox ^a.", pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename))); end; mail_format_ptr = local_mra.ms_ptr; if mail_format.notify & ^msg_facility_mailbox.notify_mail then do; call mailbox_$delete_index (msg_facility_mailbox.index, message_id, code); free mail_format in (sys_area); return; end; call get_message_index (message_id, current_message_index, code); if code = 0 then new_message_number = internal_msg_array.message_number (current_message_index); else if code = error_table_$no_message then do; if (^mail_format.notify & msg_facility_mailbox.hold_messages) | (msg_facility_mailbox.hold_notifications & mail_format.notify) then do; new_message_number = msg_facility_mailbox.highest_message + 1; msg_facility_mailbox.highest_message = new_message_number; end; else new_message_number = 0; /* Update message array, adding new message at the end (unless it's the fairly rare case in which this message was added before others that have already been received but the wakeup came later). */ msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages + 1; if msg_facility_mailbox.n_messages > msg_facility_mailbox.n_elements then do; n_messages = msg_facility_mailbox.n_elements + MSG_ARRAY_BLOCK_SIZE; allocate msg_array in (sys_area); if msg_facility_mailbox.messages_ptr ^= null () then do; array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - 1); destination_string_ptr = addr (msg_array (1)); source_string_ptr = addr (internal_msg_array (1)); destination_string = source_string; free internal_msg_array in (sys_area); end; msg_facility_mailbox.n_elements = n_messages; msg_facility_mailbox.messages_ptr = msg_array_ptr; end; idx = msg_facility_mailbox.n_messages; /* See if we need to insert this message at a different point in the message array. */ if idx ^= 1 then do; found = FALSE; do while (^found & idx > 1); if internal_msg_array.message_id (idx - 1) < message_id then found = TRUE; else idx = idx - 1; end; if idx ^= msg_facility_mailbox.n_messages then do; array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - idx); call mrl_ (addr (internal_msg_array (idx)), array_length, addr (internal_msg_array (idx + 1)), array_length); end; end; internal_msg_array.message_id (idx) = message_id; internal_msg_array.message_number (idx) = new_message_number; d_permission = substr (access_mode, 2, 1); if d_permission then internal_msg_array.printed (idx) = mail_format.seen; else internal_msg_array.printed (idx) = FALSE; internal_msg_array.mbz (idx) = ""b; current_message_index = idx; end; /* update last message info */ message_info_ptr = msg_facility_mailbox.last_message_ptr; if message_info_ptr ^= null () then do; mail_format_ptr = message_info.message_ptr; if mail_format_ptr ^= null () then free mail_format in (sys_area); free message_info in (sys_area); end; allocate message_info in (sys_area); message_info.version = MESSAGE_INFO_VERSION_1; message_info.sender = local_mra.sender_id; message_info.message_ptr = local_mra.ms_ptr; message_info.authorization = local_mra.sender_authorization; msg_facility_mailbox.last_id = message_id; msg_facility_mailbox.last_message_ptr = message_info_ptr; msg_facility_mailbox.last_message_number = internal_msg_array.message_number (current_message_index); /* Call handler. */ call msg_facility_mailbox.wakeup_handler (msg_facility_mailbox_ptr, msg_facility_mailbox.wakeup_info_ptr); return; /* wakeup_processor */ /* This entry is the default alarm handler. */ default_alarm_handler: entry (P_msgf_mbx_ptr, P_info_ptr); msg_facility_mailbox_ptr = P_msgf_mbx_ptr; if msg_facility_mailbox.n_messages = 0 then return; use_call_string = FALSE; if P_info_ptr ^= null then if call_string ^= "" then use_call_string = TRUE; if ^use_call_string then call ioa_$ioa_switch (iox_$user_io, "^[You have^;There are^] ^d message^[s^]^[ in ^a^].", msg_facility_mailbox.default_mbx, msg_facility_mailbox.n_messages, (msg_facility_mailbox.n_messages ^= 1), ^msg_facility_mailbox.default_mbx, pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename))); do idx = 1 to msg_facility_mailbox.n_messages; call process_message (internal_msg_array.message_id (idx)); end; call iox_$control (iox_$user_io, "start", null (), code); return; /* default_alarm_handler */ /* This entry is the default wakeup handler. */ default_wakeup_handler: entry (P_msgf_mbx_ptr, P_info_ptr); msg_facility_mailbox_ptr = P_msgf_mbx_ptr; use_call_string = FALSE; if P_info_ptr ^= null () then if call_string ^= "" then use_call_string = TRUE; call process_message (msg_facility_mailbox.last_id); call iox_$control (iox_$user_io, "start", null (), code); return; /* default_wakeup_handler */ /* This procedure returns a message array index given a message ID. */ get_message_index: procedure (P_message_id, P_message_index, P_code); dcl P_message_id bit (72) aligned parm; dcl P_message_index fixed bin parm; dcl P_code fixed bin (35) parm; dcl idx fixed bin; dcl (max_idx, high_idx, low_idx, high_temp, low_temp) fixed bin; dcl message_id bit (54) aligned; dcl done_searching bit (1) aligned; P_message_index = 0; if msg_facility_mailbox.n_messages = 0 then do; P_code = error_table_$no_message; return; end; P_code = 0; message_id = substr (P_message_id, 19, 54); /* date/time portion */ low_idx = 1; if ^msg_facility_mailbox.msg_array_compacted then max_idx = msg_facility_mailbox.n_elements; else max_idx = msg_facility_mailbox.n_messages; /* faster */ high_idx = max_idx; idx = divide (high_idx + low_idx, 2, 17, 0); done_searching = FALSE; do while (^done_searching); if internal_msg_array.message_id (idx) = ""b then do; /* deleted */ high_temp = min (idx + 1, max_idx); low_temp = max (idx - 1, 1); do while (high_temp < max_idx & internal_msg_array.message_id (high_temp) = ""b); high_temp = high_temp + 1; end; do while (low_temp > 1 & internal_msg_array.message_id (low_temp) = ""b); low_temp = low_temp - 1; end; if substr (internal_msg_array.message_id (high_temp), 19, 54) > message_id | internal_msg_array.message_id (high_temp) = ""b then high_idx = low_temp; else low_idx = high_temp; if idx > high_idx then idx = high_idx; else if idx < low_idx then idx = low_idx; end; else if substr (internal_msg_array.message_id (idx), 19, 54) < message_id then do; if idx >= max_idx then done_searching = TRUE; else if substr (internal_msg_array.message_id (idx + 1), 19, 54) > message_id then done_searching = TRUE; else do; low_idx = idx; idx = idx + max (divide (high_idx - idx, 2, 17, 0), 1); end; end; else if idx = 1 then done_searching = TRUE; else if substr (internal_msg_array.message_id (idx - 1), 19, 54) < message_id then done_searching = TRUE; else do; high_idx = idx; idx = idx - max (divide (idx - low_idx, 2, 17, 0), 1); end; end; if message_id ^= substr (internal_msg_array.message_id (idx), 19, 54) then P_code = error_table_$no_message; else P_message_index = idx; return; end get_message_index; /* This procedure creates or updates the message array. */ create_message_array: procedure; dcl msg_existence_array (msg_facility_mailbox.n_messages) bit (1) aligned; dcl old_msg_count fixed bin; dcl msg_count fixed bin; dcl n_deleted fixed bin; /* initialize msg existence array */ msg_existence_array (*) = FALSE; old_msg_count = msg_facility_mailbox.n_messages; msg_count = 0; /* compact message array */ if ^msg_facility_mailbox.msg_array_compacted then call compact_message_array; /* add new messages to array */ mail_format_ptr = null (); on cleanup begin; if mail_format_ptr ^= null () then free mail_format in (sys_area); end; /* Determine which mailbox_ entry points to use. */ call mailbox_$get_mode_index (msg_facility_mailbox.index, access_mode, code); if code ^= 0 then return; own = ^substr (access_mode, 3, 1); MSG_ARRAY_NEW_READ: if ^own then call mailbox_$read_index (msg_facility_mailbox.index, area_ptr, READ_FIRST, addr (local_mra), code); else call mailbox_$own_read_index (msg_facility_mailbox.index, area_ptr, READ_FIRST, addr (local_mra), code); if code = error_table_$seg_unknown then do; call mailbox_$open ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename), msg_facility_mailbox.index, code); if code ^= 0 then return; go to MSG_ARRAY_NEW_READ; end; do while (code = 0); mail_format_ptr = local_mra.ms_ptr; message_id = local_mra.ms_id; found = FALSE; do idx = 1 to msg_facility_mailbox.n_messages while (^found); if internal_msg_array.message_id (idx) = message_id then do; /* found message */ found = TRUE; msg_existence_array (idx) = TRUE; msg_count = msg_count + 1; if internal_msg_array.message_number (idx) = 0 then if (msg_facility_mailbox.hold_messages & ^mail_format.notify) | (msg_facility_mailbox.hold_notifications & mail_format.notify) then do; /* already in mbx, now in hold mode */ msg_facility_mailbox.highest_message = msg_facility_mailbox.highest_message + 1; internal_msg_array.message_number (idx) = msg_facility_mailbox.highest_message; end; /* assign number to old message */ else ; else /* message_number is nonzero, do we want to make it zero? */ if (^msg_facility_mailbox.hold_messages & ^mail_format.notify) | (^msg_facility_mailbox.hold_notifications & mail_format.notify) then internal_msg_array.message_number (idx) = 0; /* already in mailbox, now in non-hold mode */ end; /* found message */ end; if ^found & mail_format.wakeup then do; /* add this message */ msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages + 1; if msg_facility_mailbox.n_messages > msg_facility_mailbox.n_elements then do; n_messages = msg_facility_mailbox.n_elements + MSG_ARRAY_BLOCK_SIZE; allocate msg_array in (sys_area); if msg_facility_mailbox.messages_ptr ^= null () then do; array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - 1); destination_string_ptr = addr (msg_array (1)); source_string_ptr = addr (internal_msg_array (1)); destination_string = source_string; free internal_msg_array in (sys_area); end; msg_facility_mailbox.n_elements = n_messages; msg_facility_mailbox.messages_ptr = msg_array_ptr; end; jdx = msg_facility_mailbox.n_messages; /* See if we need to insert this message at a different point in the message array. */ if jdx ^= 1 then do; found = FALSE; do while (^found & jdx > 1); if internal_msg_array.message_id (jdx - 1) < message_id then found = TRUE; else jdx = jdx - 1; end; if jdx ^= msg_facility_mailbox.n_messages then do; array_length = MSG_ARRAY_ELEMENT_LENGTH * (msg_facility_mailbox.n_messages - jdx); call mrl_ (addr (internal_msg_array (jdx)), array_length, addr (internal_msg_array (jdx + 1)), array_length); end; end; internal_msg_array.message_id (jdx) = message_id; d_permission = substr (access_mode, 2, 1); if d_permission then internal_msg_array.printed (jdx) = mail_format.seen; else internal_msg_array.printed (jdx) = FALSE; internal_msg_array.mbz (jdx) = ""b; if (msg_facility_mailbox.hold_messages & ^mail_format.notify) | (msg_facility_mailbox.hold_notifications & mail_format.notify) then do; internal_msg_array.message_number (jdx) = msg_facility_mailbox.highest_message + 1; msg_facility_mailbox.highest_message = msg_facility_mailbox.highest_message + 1; end; else internal_msg_array.message_number (jdx) = 0; end; /* new one */ if mail_format_ptr ^= null () then do; free mail_format in (sys_area); mail_format_ptr = null (); end; if ^own then call mailbox_$incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD, message_id, addr (local_mra), code); else call mailbox_$own_incremental_read_index (msg_facility_mailbox.index, area_ptr, READ_FORWARD, message_id, addr (local_mra), code); end; if code = error_table_$no_message then code = 0; else if code ^= 0 then return; /* Now delete messages which are no longer in the mailbox, if any. */ if msg_count < old_msg_count then do; n_deleted = 0; msg_facility_mailbox.msg_array_compacted = FALSE; do idx = 1 to old_msg_count while (n_deleted < old_msg_count - msg_count); if ^msg_existence_array (idx) then do; /* we didn't find this one */ n_deleted = n_deleted + 1; msg_facility_mailbox.n_messages = msg_facility_mailbox.n_messages - 1; internal_msg_array.message_id (idx) = ""b; internal_msg_array.message_number (idx) = 0; end; end; call compact_message_array; end; /* If we don't own this mailbox (no "d") then assign numbers in sequence. This allows us to delete our messages by number in another's mailbox. */ if own | ^substr (access_mode, 2, 1) then do; msg_facility_mailbox.highest_message = 0; do idx = 1 to msg_facility_mailbox.n_messages; msg_facility_mailbox.highest_message = msg_facility_mailbox.highest_message + 1; internal_msg_array.message_number (idx) = msg_facility_mailbox.highest_message; end; end; if code = error_table_$no_message then code = 0; if msg_facility_mailbox.wakeup_state = "10"b then msg_facility_mailbox.msg_array_updated = TRUE; end create_message_array; /* This procedure compacts the message array. */ compact_message_array: procedure; idx, last_index = 0; do while (last_index < msg_facility_mailbox.n_messages); idx = idx + 1; last_index = last_index + 1; do while (idx < msg_facility_mailbox.n_elements & internal_msg_array.message_id (idx) = ""b); idx = idx + 1; end; if idx ^= last_index & internal_msg_array.message_id (idx) ^= ""b then do; internal_msg_array (last_index) = internal_msg_array (idx); internal_msg_array.message_id (idx) = ""b; internal_msg_array.message_number (idx) = 0; end; end; if msg_facility_mailbox.messages_ptr ^= null () & last_index ^= 0 then if internal_msg_array.message_id (last_index) = ""b then last_index = last_index - 1; msg_facility_mailbox.n_messages = last_index; msg_facility_mailbox.msg_array_compacted = TRUE; end compact_message_array; /* This procedure removes control characters (except backspace, tab, red ribbon shift, and black ribbon shift) and canonicalizes strings to prevent backspacing past the front of the string. */ canon: procedure (P_string, P_string_len) returns (char (*)); dcl P_string char (*) parm; dcl P_string_len fixed bin (21) parm; dcl output_string char (P_string_len); P_string = translate (P_string, ALPHABET); if index (P_string, BS) ^= 0 then do; output_string = ""; call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0)); return (output_string); end; else return (P_string); end canon; /* This procedure sends an acknowledgement message. */ send_acknowledgement: procedure; authorization = get_authorization_ (); if aim_check_$greater_or_equal (local_mra.sender_authorization, authorization) then do; call get_person_and_project; send_mail_info.version = send_mail_info_version_2; send_mail_info.sent_from = full_name; send_mail_info.wakeup = TRUE; send_mail_info.always_add = TRUE; send_mail_info.never_add = FALSE; send_mail_info.notify = TRUE; send_mail_info.acknowledge = FALSE; send_mail_info.mbz = ""b; person_id = before (substr (local_mra.sender_id, 1, length (rtrim (local_mra.sender_id)) - 2), "."); project_id = after (substr (local_mra.sender_id, 1, length (rtrim (local_mra.sender_id)) - 2), "."); dname = ">udd>" || rtrim (project_id) || ">" || person_id; ename = rtrim (person_id) || ".mbx"; date_time = fixed (substr (local_mra.ms_id, 19, 54), 71); call date_time_ (date_time, msg_date_time); call date_time_ (clock (), current_date_time); if msg_date_time = current_date_time then message = "Acknowledged."; else message = "Acknowledge message of " || msg_date_time; code = 1; if person_id = "anonymous" then do; login_name = local_mra.ms_ptr -> mail_format.sent_from; call message_facility_$send_message (">udd>" || rtrim (project_id) || ">" || login_name, rtrim (login_name) || ".mbx", message, addr (send_mail_info), code); if code ^= error_table_$noentry then code = 0; end; if code ^= 0 then call message_facility_$send_message (dname, ename, message, addr (send_mail_info), (0)); end; mail_format.acknowledge = FALSE; call mailbox_$update_message_index (msg_facility_mailbox.index, 36 * (fixed (rel (addr (mail_format.text))) - fixed (rel (addr (mail_format.version)))), message_id, local_mra.ms_ptr, (0)); end send_acknowledgement; /* This procedure prints out a message or executes the supplied call string. */ process_message: procedure (P_message_id); dcl P_message_id bit (72) aligned parm; dcl message_id bit (72) aligned; dcl message_index fixed bin; message_id = P_message_id; mail_format_ptr = null (); local_mi.version = MESSAGE_INFO_VERSION_1; call get_message_index (message_id, message_index, code); if code ^= 0 then return; on cleanup begin; if mail_format_ptr ^= null () then free mail_format in (sys_area); end; call message_facility_$read_message (msg_facility_mailbox_ptr, message_id, area_ptr, addr (local_mi), code); if code ^= 0 then return; mail_format_ptr = local_mi.message_ptr; date_time = fixed (substr (message_id, 19, 54), 71); call date_time_ (date_time, msg_date_time); /* create message sender string */ if mail_format.sent_from = before (local_mi.sender, ".") | rtrim (mail_format.sent_from) = "" then message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2); else message_sender = substr (local_mi.sender, 1, length (rtrim (local_mi.sender)) - 2) || " (" || rtrim (canon (rtrim (mail_format.sent_from), length (rtrim (mail_format.sent_from)))) || ")"; authorization = get_authorization_ (); if ^aim_check_$greater_or_equal (local_mi.authorization, authorization) then do; call convert_access_class_$to_string_short (local_mi.authorization, auth_string, code); if auth_string = "" then auth_string = "system_low"; message_sender = rtrim (message_sender) || " at " || auth_string; end; if use_call_string then do; call ioa_$rsnnl ("^a ^d ^a ^a ^a^[ ^a^]", command_line, (0), call_string, internal_msg_array.message_number (message_index), requote_string_ (rtrim (message_sender)), requote_string_ (rtrim (date_time_$format ("date_time", date_time, "", ""))), requote_string_ (rtrim (canon (rtrim (mail_format.text, NLSPHT), length (rtrim (mail_format.text, NLSPHT))))), ^msg_facility_mailbox.default_mbx, requote_string_ (pathname_ ((msg_facility_mailbox.dname), (msg_facility_mailbox.ename)))); /* If this message is supposed to be deleted, do so. */ if (mail_format.notify & ^msg_facility_mailbox.hold_notifications) | (^mail_format.notify & ^msg_facility_mailbox.hold_messages) then call message_facility_$set_seen_switch (msg_facility_mailbox_ptr, message_id, DELETE_UNHELD, (0)); call cu_$cp (addr (command_line), length (rtrim (command_line)), (0)); end; else do; /* print message */ string (msg_print_flags) = ""b; if message_sender = last_sender then short = TRUE; else short = FALSE; /* print prefix, it may contain ioa_ controls */ if ^short | msg_facility_mailbox.short_prefix then msg_print_flags.print_prefix = TRUE; /* if not default mailbox, prefix with mailbox entry name */ if ^msg_facility_mailbox.default_mbx then msg_print_flags.print_ename = TRUE; if ^msg_facility_mailbox.short_format | ^short then msg_print_flags.print_sender = TRUE; if ^msg_facility_mailbox.short_format | substr (msg_date_time, 1, 8) ^= last_msg_time then msg_print_flags.print_date_and_time = TRUE; else if date_time - last_time > FIVE_MINUTES then msg_print_flags.print_time = TRUE; last_sender = message_sender; last_time = date_time; last_msg_time = substr (msg_date_time, 1, 8); call message_facility_$print_message (msg_facility_mailbox_ptr, iox_$user_io, message_id, addr (msg_print_flags), code); call message_facility_$set_seen_switch (msg_facility_mailbox_ptr, message_id, DELETE_UNHELD, code); end; if mail_format_ptr ^= null () then free mail_format in (sys_area); end process_message; /* Get person ID, project ID, and full name. */ get_person_and_project: procedure; if person = "" then call user_info_$whoami (person, project, ""); /* Since the full name is stored in the "sent_from" field of the mail_format structure, we don't get a value from the value segment for an anonymous user since it is important that the login name be there so that replies and acknowledgements get sent to the right place. When we change this to use mail_system_ more fully, we can do the right thing. */ if full_name = "" & person ^= "anonymous" then do; call value_$get (null (), PERMANENT_VALUES, rtrim (person) || ".full_name._", full_name, code); if code ^= 0 then call value_$get (null (), PERMANENT_VALUES, "full_name._", full_name, code); if code ^= 0 then full_name = person; end; else if person = "anonymous" then full_name = person; end get_person_and_project; %page; %include event_call_info; %page; %include last_message_info; %page; %include mail_format; %page; %include message_info; %page; %include mseg_return_args; %page; %include msg_array; %page; %include msg_facility_mailbox; %page; %include msg_print_flags; %page; %include send_mail_info; %page; %include sub_err_flags; end message_facility_;  message_status.pl1 06/30/86 1407.4rew 06/30/86 1342.8 125334 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* This command prints information about mailboxes on which messages are being accepted or deferred. */ /****^ HISTORY COMMENTS: 1) change(84-06-11,Lippard), approve(), audit(), install(86-06-30,MR12.0-1080): Written by Jim Lippard. 2) change(85-09-10,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to work as an active function. 3) change(86-05-09,Lippard), approve(86-06-24,MCR7434), audit(86-06-24,Hartogs), install(86-06-30,MR12.0-1080): Modified to reject -all as an active function. END HISTORY COMMENTS */ message_status: msgst: procedure options (variable); dcl ME char (14) internal static options (constant) init ("message_status"); dcl VERSION char (3) internal static options (constant) init ("1.2"); dcl com_err_ entry () options (variable); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl interpret_ptr_ entry (ptr, ptr, ptr); dcl ioa_ entry () options (variable); dcl mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35)); dcl message_facility_$default_wakeup_handler entry (ptr, ptr); dcl message_facility_$default_alarm_handler entry (ptr, ptr); dcl message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$get_msg_array_ptr entry (ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl message_facility_$get_wakeup_state entry (ptr, bit (*), fixed bin (35)); dcl message_facility_$get_message_format entry (ptr, bit (1) aligned, fixed bin (35)); dcl message_facility_$get_prefix entry (ptr, char (32) var, bit (1) aligned, fixed bin (35)); dcl message_facility_$get_alarm_handler entry (ptr, entry, ptr, fixed bin (71), fixed bin (35)); dcl message_facility_$get_wakeup_handler entry (ptr, entry, ptr, fixed bin (35)); dcl message_facility_$get_next_msgf_mbx_ptr entry (ptr, ptr); dcl message_facility_$get_mbx_path entry (ptr, char (*), char (*), bit (1) aligned, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$print_message entry () options (variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl cleanup condition; dcl active_function bit (1) aligned; dcl alarm_handler variable entry (ptr, ptr); dcl alarm_info_ptr ptr; dcl alarm_time fixed bin (71); dcl alarm_ptr ptr; dcl alarm_dname char (168); dcl alarm_ename char (32); dcl all bit (1) aligned; dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl call_string char (512) aligned based (call_string_ptr); dcl call_string_ptr ptr; dcl default bit (1) aligned; dcl dname char (168); dcl ename char (32); dcl flags bit (5); dcl idx fixed bin; dcl 1 local_pcao aligned like parse_ca_options; dcl msgf_mbx_ptr ptr; dcl path bit (1) aligned; dcl person char (22); dcl project char (9); dcl prefix char (32) var; dcl printed_something bit (1) aligned; dcl return_ptr ptr; dcl return_len fixed bin (21); dcl return_arg char (return_len) varying based (return_ptr); dcl return_string char (2000) varying; dcl sci_ptr ptr; dcl short_format bit (1) aligned; dcl short_prefix bit (1) aligned; dcl strp ptr; dcl sys_area area based (sys_area_ptr); dcl sys_area_ptr ptr; dcl wakeup_handler variable entry (ptr, ptr); dcl wakeup_info_ptr ptr; dcl wakeup_ptr ptr; dcl wakeup_dname char (168); dcl wakeup_ename char (32); dcl (addr, character, codeptr, environmentptr, ltrim, null, rtrim, substr) builtin; dcl code fixed bin (35); dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); /* initialize variables */ all, default, path, printed_something = FALSE; msg_array_ptr, sci_ptr = null (); sys_area_ptr = get_system_free_area_ (); on cleanup call cleanup_msgst; /* create ssu_ invocation */ call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null (), abort_msgst, code); if code ^= 0 then do; call com_err_ (code, ME, "Creating standalone subsystem invocation."); return; end; /* process arguments */ call ssu_$return_arg (sci_ptr, arg_count, active_function, return_ptr, return_len); do idx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if (arg = "-all" | arg = "-a") & ^active_function then all = TRUE; else do; /* let mlsys_utils_ have at it */ local_pcao.version = PARSE_CA_OPTIONS_VERSION_1; local_pcao.logbox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.savebox_creation_mode = DONT_CREATE_MAILBOX; local_pcao.abort_on_errors = TRUE; local_pcao.validate_addresses = FALSE; local_pcao.mbz = ""b; call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (local_pcao), dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); idx = idx - 1; if path then call ssu_$abort_line (sci_ptr, (0), "Usage: msgst {mbx_specification} {-control_args}"); path = TRUE; end; end; if all & path then call ssu_$abort_line (sci_ptr, (0), "A mailbox specification and ""-all"" are mutually exclusive."); if ^all & ^path then do; call user_info_$whoami (person, project, ""); dname = ">udd>" || rtrim (project) || ">" || person; ename = rtrim (person) || ".mbx"; default = TRUE; end; if all then do; call message_facility_$get_next_msgf_mbx_ptr (null (), msgf_mbx_ptr); do while (msgf_mbx_ptr ^= null ()); call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); if substr (flags, 4, 2) ^= "00"b then do; call message_facility_$get_mbx_path (msgf_mbx_ptr, dname, ename, default, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); call process_mailbox; printed_something = TRUE; end; call message_facility_$get_next_msgf_mbx_ptr (msgf_mbx_ptr, msgf_mbx_ptr); end; if ^printed_something then call ssu_$abort_line (sci_ptr, (0), "You are not currently accepting or deferring messages on any mailboxes."); end; else do; call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", pathname_ (dname, ename)); if substr (flags, 4, 2) = "00"b then call ssu_$abort_line (sci_ptr, (0), "You are not accepting or deferring messages on the specified mailbox. ^a", pathname_ (dname, ename)); call process_mailbox; end; call cleanup_msgst; RETURN_FROM_MST: return; process_mailbox: proc; return_string = ""; /* get wakeup state */ call message_facility_$get_wakeup_state (msgf_mbx_ptr, flags, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; /* get message format */ call message_facility_$get_message_format (msgf_mbx_ptr, short_format, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; /* get prefix */ call message_facility_$get_prefix (msgf_mbx_ptr, prefix, short_prefix, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; /* get handler info */ call message_facility_$get_wakeup_handler (msgf_mbx_ptr, wakeup_handler, wakeup_info_ptr, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; /* get alarm info */ call message_facility_$get_alarm_handler (msgf_mbx_ptr, alarm_handler, alarm_info_ptr, alarm_time, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; /* convert wakeup/alarm handlers to char strings */ wakeup_ptr = codeptr (wakeup_handler); alarm_ptr = codeptr (alarm_handler); call hcs_$fs_get_path_name (wakeup_ptr, wakeup_dname, (0), wakeup_ename, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; call hcs_$fs_get_path_name (alarm_ptr, alarm_dname, (0), alarm_ename, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; if ^active_function then do; /* get number of messages */ call message_facility_$get_msg_array_ptr (msgf_mbx_ptr, sys_area_ptr, msg_array_ptr, n_messages, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "^a", pathname_ (dname, ename)); return; end; /* print info */ call ioa_ ("^[^/^]Mailbox: ^a^[ (default)^]", printed_something, pathname_ (dname, ename), default); call ioa_ ("Number of messages: ^d", n_messages); call ioa_ ("Wakeup state: ^[deferring^;accepting^] messages", substr (flags, 5, 1)); call ioa_ ("^3x^[not ^]holding messages", ^substr (flags, 1, 1)); call ioa_ ("^3x^[not ^]holding notifications", ^substr (flags, 2, 1)); call ioa_ ("^3x^[not ^]printing notifications", ^substr (flags, 3, 1)); call ioa_ ("Message format: ^[short^;long^]", short_format); if prefix ^= "" then call ioa_ ("Prefix string: ^a^[ (short prefix)^]", prefix, short_prefix); call interpret_ptr_ (codeptr (wakeup_handler), environmentptr (wakeup_handler), addr (strbuf)); call ioa_ ("Wakeup handler: ^a^a^/^3x(^a|^a)", strbuf.segment, strbuf.entryn, pathname_ (wakeup_dname, wakeup_ename), strbuf.offset); call_string_ptr = wakeup_info_ptr; if wakeup_handler = message_facility_$default_wakeup_handler & wakeup_info_ptr ^= null () then if call_string ^= "" then call ioa_ ("^[Wakeup call^;Call^] string: ^a", (wakeup_info_ptr ^= alarm_info_ptr), call_string); if alarm_time ^= 0 then do; call interpret_ptr_ (codeptr (alarm_handler), environmentptr (alarm_handler), addr (strbuf)); call ioa_ ("Alarm handler: ^a^a^/^3x(^a|^a)", strbuf.segment, strbuf.entryn, pathname_ (alarm_dname, alarm_ename), strbuf.offset); call ioa_ ("Alarm wakeup every ^d seconds", alarm_time); call_string_ptr = alarm_info_ptr; if (wakeup_info_ptr ^= alarm_info_ptr) & (alarm_handler = message_facility_$default_alarm_handler) & (alarm_info_ptr ^= null ()) then if call_string ^= "" then call ioa_ ("Alarm call string: ^a", call_string); end; end; else do; /* active function case */ if wakeup_handler ^= message_facility_$default_wakeup_handler | alarm_handler ^= message_facility_$default_alarm_handler then call ssu_$abort_line (sci_ptr, (0), "The current wakeup state cannot be described by control arguments due to non-standard alarm or wakeup handler."); return_string = "accept_messages -mailbox " || rtrim (pathname_ (dname, ename)); if substr (flags, 1, 1) then return_string = return_string || " -hold_messages"; else return_string = return_string || " -no_hold_messages"; if substr (flags, 2, 1) then return_string = return_string || " -hold_notifications"; else return_string = return_string || " -no_hold_notifications"; if substr (flags, 3, 1) then return_string = return_string || " -notifications"; else return_string = return_string || " -no_notifications"; if short_format then return_string = return_string || " -short"; else return_string = return_string || " -long"; return_string = return_string || " -prefix """ || prefix || """"; if short_prefix then return_string = return_string || " -short_prefix"; else return_string = return_string || " -no_short_prefix"; call_string_ptr = wakeup_info_ptr; if wakeup_info_ptr ^= null () then return_string = return_string || " -call """ || rtrim (call_string) || """"; else return_string = return_string || " -call """""; return_string = return_string || " -time " || ltrim (character (alarm_time)); if substr (flags, 5, 1) then return_string = return_string || ";defer_messages"; return_arg = return_string; end; /* active function case */ end process_mailbox; cleanup_msgst: proc; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); if msg_array_ptr ^= null () then free msg_array in (sys_area); return; end cleanup_msgst; abort_msgst: proc; call cleanup_msgst; go to RETURN_FROM_MST; end abort_msgst; %page; %include interpret_ptr_struc; %page; %include mlsys_parse_ca_options; %page; %include msg_array; end message_status;  send_mail_.pl1 06/30/86 1407.4rew 06/30/86 1342.1 45225 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-02,Herbst), approve(86-06-02,MCR7432), audit(86-06-30,Wong), install(86-06-30,MR12.0-1080): Changed to initialize unused portions of mail_format to zero. END HISTORY COMMENTS */ send_mail_: proc (destination, message, send_info_ptr, code); /* This subroutine sends one message to a specified Person.Project destination and optionally accompanies it with a wakeup. Control information is input via the structure send_mail_info. */ /* Steve Herbst 7/1/75 */ /* Arguments declared char (*) 05/12/80 S. Herbst */ %include mail_format; %include send_mail_info; dcl 1 send_info like send_mail_info based(send_info_ptr); dcl (destination, message) char(*); dcl (a_dn, a_en) char (*); dcl dn char (168); dcl en char (32); dcl newline char(1) aligned init(" "); dcl switch bit(36) init("0"b); dcl (a_access_class, access_class, id) bit(72) aligned; dcl aim_add bit(1) aligned; dcl retried bit(1) aligned; /* retried once already after $bad_segment */ dcl send_info_ptr ptr; dcl (count, i, j) fixed bin; dcl mbx_index fixed bin init(0); /* index of recipient's mailbox */ dcl msg_bitcnt fixed bin; /* bitcnt of message added */ dcl code fixed bin(35); dcl error_table_$bad_segment fixed bin(35) ext; dcl error_table_$noentry fixed bin(35) ext; dcl error_table_$rqover fixed bin(35) ext; dcl mailbox_$close entry(fixed bin,fixed bin(35)); dcl mailbox_$open entry(char(*),char(*),fixed bin,fixed bin(35)); dcl mailbox_$wakeup_add_index entry(fixed bin,ptr,fixed bin,bit(36),bit(72)aligned,fixed bin(35)); dcl mailbox_$wakeup_aim_add_index entry(fixed bin,ptr,fixed bin,bit(36),bit(72)aligned,bit(72)aligned,fixed bin(35)); dcl (addr, index, length, reverse, size, substr, verify) builtin; dcl (cleanup, record_quota_overflow) condition; /* */ aim_add = "0"b; go to COMMON; access_class: entry (destination, message, send_info_ptr, a_access_class, code); aim_add = "1"b; access_class = a_access_class; /* locate recipient's mailbox */ COMMON: i = index(destination,"."); j = length(destination) + 1 - verify(reverse(destination)," "); if i=0 then do; /* invalid destination */ code = error_table_$noentry; /* no such mailbox */ return; end; else do; dn = ">udd>" || substr(destination,i+1,j-i) || ">" || substr(destination,1,i-1); en = substr(destination,1,i-1) || ".mbx"; end; go to OPEN; path: entry (a_dn, a_en, message, send_info_ptr, code); aim_add = "0"b; go to COMMON2; path_access_class: entry (a_dn, a_en, message, send_info_ptr, a_access_class, code); aim_add = "1"b; access_class = a_access_class; COMMON2: dn = a_dn; en = a_en; i = length (rtrim (en)); if i < 5 then do; ADD_SUFFIX: substr (en, i + 1, 4) = ".mbx"; end; else if substr (en, i - 3, 4) ^= ".mbx" then go to ADD_SUFFIX; OPEN: on condition (cleanup) begin; if mbx_index ^= 0 then call mailbox_$close (mbx_index, 0); end; call mailbox_$open(dn,en,mbx_index,code); if code^=0 then return; /* build message */ if message="" then text_length = 0; else text_length = length(message)-verify(reverse(message)," ")+1; msg_bitcnt = size(mail_format)*36; allocate_message: begin; dcl mf_space bit(msg_bitcnt) aligned; dcl 1 mf aligned like mail_format based(addr(mf_space)); mf.version = MAIL_FORMAT_VERSION_4; mf.text_len = text_length; mf.sent_from = send_info.sent_from; mf.wakeup = send_info.wakeup; mf.notify = send_info.notify; mf.acknowledge = send_info.acknowledge; mf.urgent, mf.seen, mf.others = "0"b; mf.text = message; /* count lines */ mf.lines = 0; count = 1; i = 1; do while(i^=0 & text_length^=0); i = index(substr(message,count,text_length),newline); count = count+i; text_length = text_length-i; mf.lines = mf.lines+1; end; /* send */ on condition(record_quota_overflow) begin; code = error_table_$rqover; go to RETURN; end; switch = mf.wakeup || mf.urgent || send_info.always_add || send_info.never_add; retried = "0"b; RETRY: if aim_add then call mailbox_$wakeup_aim_add_index (mbx_index,addr(mf),msg_bitcnt,switch,access_class,id,code); else call mailbox_$wakeup_add_index(mbx_index,addr(mf),msg_bitcnt,switch,id,code); if code=error_table_$bad_segment & ^retried then do; retried = "1"b; go to RETRY; end; call mailbox_$close(mbx_index,0); end allocate_message; RETURN: return; end send_mail_;  send_message.pl1 12/07/87 1327.6rew 12/07/87 1321.4 232209 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(83-11-22,Lippard), approve(), audit(), install(): A rewrite by Jim Lippard of the send_message command which was part of message_facility.pl1 (written 12/01/75 by Steve Herbst). This is the standard command for sending interactive messages. 2) change(84-06-26,Lippard), approve(), audit(), install(): Modified to merge in "accepting" (based on the original "accepting" written by James R. Davis on April 29, 1980 which was based on an idea of Paul Benjamin). 3) change(84-11-15,Lippard), approve(), audit(), install(): Modified to remove the short name "acc" from accepting. 4) change(84-12-14,Lippard), approve(), audit(), install(): Modified to do the right thing with error_table_$no_info. 5) change(85-06-03,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to handle errors properly for accepting. 6) change(85-08-19,Lippard), approve(85-11-18,MCR7298), audit(86-01-10,Spitzer), install(86-01-20,MR12.0-1006): Modified to correct the error message produced when attempting to send a message to a user whose mail table entry points to a mailing list, add -update_destination (-upds) and -no_update_destination (-nupds), and -acknowledge_if_deferred (-ackid). 7) change(87-12-02,GWMay), approve(87-12-02,MCR7801), audit(87-12-03,Lippard), install(87-12-07,MR12.2-1008): Changed to terminate without error when the code error_table_$end_of_info is returned by iox_$get_line in the input loop. The change allows the command to be used as a filter without error. END HISTORY COMMENTS */ send_message: sm: procedure options (variable); dcl ME char (24); dcl VERSION char (3) internal static options (constant) initial ("1.4"); dcl com_err_ entry () options (variable); dcl convert_access_class_$from_string entry (bit (72) aligned, char (*), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl ioa_ entry () options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$user_input ptr ext static; dcl mail_system_$create_user_mailbox_address entry (char (*) varying, char (*) varying, char (*) varying, ptr, fixed bin (35)); dcl mail_system_$create_mail_table_address entry (char (*) varying, char (*) varying, char (*) varying, ptr, fixed bin (35)); dcl mail_system_$free_address entry (ptr, fixed bin (35)); dcl mail_system_$get_address_pathname entry (ptr, char (*), char (*), char (*), fixed bin (35)); dcl mail_system_$get_mail_table_address entry (ptr, ptr, fixed bin (35)); dcl mlsys_utils_$parse_mailbox_control_args entry (ptr, fixed bin, ptr, char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl message_facility_$get_last_message_info entry (ptr, ptr, fixed bin (35)); dcl message_facility_$get_msgf_mbx_ptr entry (char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35)); dcl message_facility_$send_message_access_class entry (char (*), char (*), char (*), ptr, bit (72) aligned, fixed bin (35)); dcl requote_string_ entry (char (*)) returns (char (*)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$print_message entry () options (variable); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl af_allowed bit (1) aligned; dcl active_function bit (1) aligned; dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl return_ptr ptr; dcl return_len fixed bin (21); dcl return_arg char (return_len) varying based (return_ptr); dcl access_class bit (1) aligned; dcl acknowledge bit (1) aligned; dcl ack_if_deferred bit (1) aligned; dcl comment bit (1) aligned; dcl control_args bit (1) aligned; dcl destination bit (1) aligned; dcl escape bit (1) aligned; dcl express bit (1) aligned; dcl inhibit_error bit (1) aligned; dcl last_destination bit (1) aligned; dcl last_sender bit (1) aligned; dcl long bit (1) aligned; dcl message_allocated bit (1) aligned; dcl print_destination bit (1) aligned; dcl no_print_destination bit (1) aligned; dcl pathname bit (1) aligned internal static; dcl suppress_errors bit (1) aligned; dcl suppress_warnings bit (1) aligned; dcl update_destination bit (1) aligned; dcl access_class_arg bit (72) aligned; dcl comment_field char (32); dcl destination_arg char (168); dcl dname char (168); dcl ename char (32); dcl person char (22); dcl project char (9); dcl last_destination_arg char (168) internal static init (""); dcl last_dname char (168) internal static init (""); dcl last_ename char (32) internal static init (""); dcl last_person char (22); dcl last_project char (9); dcl 1 local_lmi aligned like last_message_info; dcl msgf_mbx_ptr ptr; dcl idx fixed bin; dcl 1 ca_options aligned like parse_ca_options; dcl address_ptr ptr; dcl mt_address_ptr ptr; dcl chars_read fixed bin (21); dcl old_message_ptr ptr; dcl old_message_len fixed bin (21); dcl message_ptr ptr; dcl message_len fixed bin (21); dcl message_space char (1600) aligned; dcl message char (message_len) aligned based (message_ptr); dcl start_len fixed bin (21); dcl area_ptr ptr; dcl area area based (area_ptr); dcl sci_ptr ptr; dcl cleanup condition; dcl (addr, after, before, index, length, null, reverse, rtrim, search, substr) builtin; dcl TRUE bit (1) internal static options (constant) init ("1"b); dcl FALSE bit (1) internal static options (constant) init ("0"b); dcl DOT_NL char (2) internal static options (constant) init (". "); dcl (code, old_code) fixed bin (35); dcl (error_table_$badopt, error_table_$end_of_info, error_table_$long_record, error_table_$messages_deferred, error_table_$messages_off, error_table_$no_append, error_table_$noarg, error_table_$no_dir, error_table_$noentry, error_table_$wakeup_denied) external fixed bin (35); dcl mlsys_et_$invalid_user_id_syntax external fixed bin (35); ME = "send_message"; af_allowed = FALSE; active_function = FALSE; go to COMMON; accepting: entry; ME = "accepting"; af_allowed = TRUE; go to COMMON; last_message_destination: lmds: entry; ME = "last_message_destination"; af_allowed = TRUE; inhibit_error = FALSE; COMMON: /* initialize variables */ sci_ptr = null (); address_ptr, mt_address_ptr = null (); area_ptr = null (); access_class, acknowledge, ack_if_deferred, destination, express, last_destination, last_sender, long, message_allocated, suppress_errors, suppress_warnings = FALSE; comment, escape, update_destination = TRUE; print_destination, no_print_destination = FALSE; call user_info_$whoami (person, project, ""); comment_field = person; message_ptr = addr (message_space); message_len = length (message_space); message = ""; on cleanup call cleanup_sm; /* create ssu invocation */ call ssu_$standalone_invocation (sci_ptr, ME, VERSION, null, abort_sm, code); if code ^= 0 then do; call com_err_ (code, ME, "Creating standalone subsystem invocation."); return; end; /* process arguments */ if af_allowed then call ssu_$return_arg (sci_ptr, arg_count, active_function, return_ptr, return_len); else call ssu_$arg_count (sci_ptr, arg_count); if ME = "last_message_destination" then do; /* last_message_destination ends here */ do idx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg = "-inhibit_error" | arg = "-ihe" then inhibit_error = TRUE; else if index (arg, "-") = 1 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg); else call ssu_$abort_line (sci_ptr, (0), "Usage: lmds {-control_arg}"); end; if last_destination_arg = "" then do; if ^inhibit_error then call ssu_$abort_line (sci_ptr, (0), "No last message destination."); else if active_function then return_arg = ""; end; else do; if active_function then return_arg = requote_string_ (rtrim (last_destination_arg)); else call ioa_ ("^a", last_destination_arg); end; go to MAIN_RETURN; end; control_args = TRUE; do idx = 1 to arg_count while (control_args); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if (arg = "-acknowledge" | arg = "-ack") & ^af_allowed then do; acknowledge = TRUE; ack_if_deferred = FALSE; end; else if (arg = "-no_acknowledge" | arg = "-nack") & ^af_allowed then acknowledge, ack_if_deferred = FALSE; else if (arg = "-acknowledge_if_deferred" | arg = "-ackid") & ^af_allowed then do; ack_if_deferred = TRUE; acknowledge = FALSE; end; else if (arg = "-brief" | arg = "-bf") & ^af_allowed then do; suppress_warnings = TRUE; suppress_errors, long = FALSE; end; else if (arg = "-long" | arg = "-lg") & ^af_allowed then do; suppress_warnings, suppress_errors = FALSE; long = TRUE; end; else if (arg = "-silent" | arg = "-sil") & ^af_allowed then do; suppress_warnings, suppress_errors = TRUE; long = FALSE; end; else if (arg = "-comment" | arg = "-com") & ^af_allowed then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A character string must be given after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if arg_len > length (send_mail_info.sent_from) then call ssu_$abort_line (sci_ptr, (0), "Comment field may be no longer than ^d characters.", length (send_mail_info.sent_from)); comment = TRUE; comment_field = arg; end; else if (arg = "-no_comment" | arg = "-ncom") & ^af_allowed then do; comment = FALSE; comment_field = ""; end; else if (arg = "-escape" | arg = "-esc") & ^af_allowed then escape = TRUE; else if (arg = "-no_escape" | arg = "-no_escape") & ^af_allowed then escape = FALSE; else if (arg = "-express" | arg = "-xps") & ^af_allowed then express = TRUE; else if (arg = "-no_express" | arg = "-nxps") & ^af_allowed then express = FALSE; else if (arg = "-access_class" | arg = "-acc") & ^af_allowed then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "An access class must be specified after ""^a"".", arg); call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call convert_access_class_$from_string (access_class_arg, arg, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); access_class = TRUE; end; else if arg = "-last_message_destination" | arg = "-lmds" then do; if destination then call print_usage_message; destination, last_destination, print_destination = TRUE; destination_arg = last_destination_arg; dname = last_dname; ename = last_ename; end; else if arg = "-last_message_sender" | arg = "-lms" then do; if destination then call print_usage_message; dname = ">udd>" || rtrim (project) || ">" || person; ename = rtrim (person) || ".mbx"; call message_facility_$get_msgf_mbx_ptr (dname, ename, msgf_mbx_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While getting message facility mailbox pointer. ^a", pathname_ (dname, ename)); local_lmi.version = LAST_MESSAGE_INFO_VERSION_1; call message_facility_$get_last_message_info (msgf_mbx_ptr, addr (local_lmi), code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "While getting last message info. ^a", pathname_ (dname, ename)); if local_lmi.last_message_id = ""b then call ssu_$abort_line (sci_ptr, (0), "No last message."); message_info_ptr = local_lmi.last_message_ptr; destination_arg, last_destination_arg = substr (message_info.sender, 1, length (rtrim (message_info.sender)) - 2); last_person = before (destination_arg, "."); last_project = after (destination_arg, "."); dname = ">udd>" || rtrim (last_project) || ">" || last_person; ename = rtrim (last_person) || ".mbx"; destination, last_destination, last_sender, print_destination = TRUE; end; else if arg = "-pathname" | arg = "-pn" then do; idx = idx + 1; if idx > arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "A mailbox pathname must be given after ""^a"".", arg); if destination then call print_usage_message; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); destination, pathname = TRUE; destination_arg = pathname_ (dname, ename); end; else if (arg = "-print_destination" | arg = "-prds") & ^af_allowed then do; print_destination = TRUE; no_print_destination = FALSE; end; else if (arg = "-no_print_destination" | arg = "-nprds") & ^af_allowed then do; print_destination = FALSE; no_print_destination = TRUE; end; else if (arg = "-update_destination" | arg = "-upds") & ^af_allowed then update_destination = TRUE; else if (arg = "-no_update_destination" | arg = "-nupds") & ^af_allowed then update_destination = FALSE; else if index (arg, "-") ^= 1 & destination then control_args = FALSE; else if search (arg, "<>") ^= 0 then do; call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); destination = TRUE; destination_arg = arg; pathname = TRUE; end; else if index (arg, "-") ^= 1 then do; call mail_system_$create_user_mailbox_address ((arg), "", "", address_ptr, code); if code = mlsys_et_$invalid_user_id_syntax then do; call mail_system_$create_mail_table_address ((arg), "", "", address_ptr, code); if code = 0 then do; call mail_system_$get_mail_table_address (address_ptr, mt_address_ptr, code); if code = 0 then do; call mail_system_$free_address (address_ptr, (0)); address_ptr = mt_address_ptr; end; end; end; if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); call mail_system_$get_address_pathname (address_ptr, dname, ename, "", code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "^a", arg); if before (reverse (rtrim (ename)), ".") = "slm" then call ssu_$abort_line (sci_ptr, (0), "Mailing lists are not supported by this command. ^a", arg); destination = TRUE; destination_arg = arg; pathname = FALSE; end; else do; /* let mlsys_utils_ handle this potential address */ ca_options.version = PARSE_CA_OPTIONS_VERSION_1; ca_options.logbox_creation_mode = DONT_CREATE_MAILBOX; ca_options.savebox_creation_mode = DONT_CREATE_MAILBOX; ca_options.abort_on_errors = TRUE; ca_options.validate_addresses = FALSE; ca_options.mbz = ""b; call mlsys_utils_$parse_mailbox_control_args (sci_ptr, idx, addr (ca_options), dname, ename, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code); idx = idx - 1; /* let the do loop increment it rather than mlsys_utils_ */ destination = TRUE; destination_arg = pathname_ (dname, ename); pathname = TRUE; end; end; /* arg loop */ if ^control_args & af_allowed then call print_usage_message; else if ^control_args then idx = idx - 1; if ^destination then call print_usage_message; if last_destination & last_destination_arg = "" then call ssu_$abort_line (sci_ptr, (0), "No last destination."); /* set last info */ if ^af_allowed & update_destination then do; last_destination_arg = destination_arg; last_dname = dname; last_ename = ename; end; if acknowledge & ^long then suppress_warnings = TRUE; send_mail_info.version = send_mail_info_version_2; send_mail_info.sent_from = comment_field; send_mail_info.wakeup = TRUE; send_mail_info.mbz1 = ""b; send_mail_info.always_add = ^express; send_mail_info.never_add = FALSE; send_mail_info.notify = FALSE; send_mail_info.acknowledge = acknowledge; send_mail_info.mbz = ""b; code = test_sendable (); old_code = code; if ack_if_deferred & (code = error_table_$messages_deferred | code = error_table_$messages_off) then send_mail_info.acknowledge = TRUE; if af_allowed then do; /* accepting ends here */ if code = error_table_$messages_off | code = error_table_$messages_deferred then if ^active_function then call print_code (); else return_arg = "false"; else if code ^= 0 then call ssu_$print_message (sci_ptr, code, "Cannot determine accepting state. ^a", destination_arg); else if ^active_function then do; if pathname then call ssu_$print_message (sci_ptr, (0), "Messages are being accepted on the mailbox ^a.", destination_arg); else call ssu_$print_message (sci_ptr, (0), "^a is accepting messages.", destination_arg); end; else return_arg = "true"; go to MAIN_RETURN; end; if code ^= 0 then call print_code (); if idx <= arg_count then do; /* there is a message to send */ start_len = 1; message = ""; do idx = idx to arg_count; call ssu_$arg_ptr (sci_ptr, idx, arg_ptr, arg_len); if start_len + arg_len > message_len then do; /* need more space */ old_message_ptr = message_ptr; old_message_len = message_len; message_len = message_len + arg_len + length (message_space); if area_ptr = null () then area_ptr = get_system_free_area_ (); allocate message in (area) set (message_ptr); message_allocated = TRUE; message = substr (old_message_ptr -> message, 1, old_message_len); if old_message_len > length (message_space) then free old_message_ptr -> message in (area); substr (message, old_message_len + 1) = ""; end; substr (message, start_len, arg_len) = arg; start_len = start_len + arg_len + 1; end; /* arg loop */ if access_class then call message_facility_$send_message_access_class (dname, ename, substr (message, 1, start_len - 1), addr (send_mail_info), access_class_arg, code); else call message_facility_$send_message (dname, ename, substr (message, 1, start_len - 1), addr (send_mail_info), code); if message_allocated then free message in (area); if print_destination & ^no_print_destination then call ioa_ ("Sent to ^a^[ (last message ^[sender^;destination^])^].", destination_arg, last_destination, last_sender); if code ^= old_code then call print_code (); goto MAIN_RETURN; end; /* message on command line */ else do; /* input mode */ code = 0; call ioa_ ("Input to ^a:", destination_arg); do while (code = 0); call iox_$get_line (iox_$user_input, message_ptr, message_len, chars_read, code); if code ^= 0 then if code = error_table_$long_record then do; call ssu_$print_message (sci_ptr, code, "user_input"); call ssu_$print_message (sci_ptr, (0), "Maximum message length is ^d characters. Message truncated to ""^a"".", message_len, message); code = 0; end; else if code = error_table_$end_of_info then goto MAIN_RETURN; else call ssu_$abort_line (sci_ptr, code, "user_input"); if substr (message, 1, chars_read) = DOT_NL then goto MAIN_RETURN; /* exit input mode */ if substr (message, 1, 2) = ".." & escape then do; substr (message, 1, 2) = " "; call cu_$cp (message_ptr, chars_read, code); code = 0; end; else do; if access_class then call message_facility_$send_message_access_class (dname, ename, substr (message, 1, chars_read), addr (send_mail_info), access_class_arg, code); else call message_facility_$send_message (dname, ename, substr (message, 1, chars_read), addr (send_mail_info), code); if code ^= old_code then if code = 0 & ^suppress_warnings then call ssu_$print_message (sci_ptr, (0), "^[A process^s^;^a^] is now accepting messages^[ on the mailbox ^a^].", pathname, destination_arg, pathname, destination_arg); else if code ^= 0 then call print_code (); old_code = code; if code ^= 0 then if (code = error_table_$messages_off | code = error_table_$wakeup_denied | code = error_table_$messages_deferred) then code = 0; end; /* sending it */ end; /* input loop */ end; /* message with input loop */ if code ^= 0 & code ^= old_code then call print_code (); MAIN_RETURN: call cleanup_sm (); RETURN_FROM_SM: return; cleanup_sm: proc (); if message_allocated then do; message_allocated = FALSE; free message in (area); end; if address_ptr ^= null () then call mail_system_$free_address (address_ptr, (0)); if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end cleanup_sm; abort_sm: proc (); call cleanup_sm (); go to RETURN_FROM_SM; end abort_sm; test_sendable: proc () returns (fixed bin (35)); dcl return_code fixed bin (35); send_mail_info.never_add = TRUE; if access_class then call message_facility_$send_message_access_class (dname, ename, "", addr (send_mail_info), access_class_arg, return_code); else call message_facility_$send_message (dname, ename, "", addr (send_mail_info), return_code); send_mail_info.never_add = FALSE; return (return_code); end test_sendable; print_code: proc; dcl error_occurred bit (1) aligned; error_occurred = FALSE; if code = error_table_$no_append then do; if ^suppress_errors then call ssu_$print_message (sci_ptr, (0), "Insufficient access to add a message to^[ mailbox of^] ^a", ^pathname, destination_arg); error_occurred = TRUE; end; else if code = error_table_$noentry | code = error_table_$no_dir then do; if ^suppress_errors then call ssu_$print_message (sci_ptr, (0), "No mailbox^[ for^] ^a.", ^pathname, destination_arg); error_occurred = TRUE; end; else if code = error_table_$messages_off then if ^suppress_warnings then do; if pathname then call ssu_$print_message (sci_ptr, (0), "No process is accepting messages on the mailbox ^a.", destination_arg); else call ssu_$print_message (sci_ptr, (0), "^a is not accepting messages or not logged in.", destination_arg); end; else ; else if code = error_table_$messages_deferred then if ^suppress_warnings then do; if pathname then call ssu_$print_message (sci_ptr, (0), "Messages are deferred on the mailbox ^a.", destination_arg); else call ssu_$print_message (sci_ptr, (0), "^a has deferred messages.", destination_arg); end; else ; else if code = error_table_$wakeup_denied then if ^suppress_warnings then do; call ssu_$print_message (sci_ptr, (0), "Insufficient access to send a wakeup to ^a. Message may not be printed immediately.", destination_arg); end; else ; else do; error_occurred = TRUE; if ^suppress_errors then call ssu_$print_message (sci_ptr, code, "^a", destination_arg); end; if express & ((suppress_warnings & error_occurred) | ^suppress_warnings) then call ssu_$print_message (sci_ptr, (0), "Message not sent to ^a.", destination_arg); if express | error_occurred then call abort_sm (); end print_code; /* This procedure prints a usage message for accepting or send_message */ print_usage_message: procedure; if af_allowed then call ssu_$abort_line (sci_ptr, (0), "Usage: ^[[^]accepting address^[]^]", active_function, active_function); else call ssu_$abort_line (sci_ptr, (0), "Usage: sm {-control_args} address {message}"); end print_usage_message; %page; %include last_message_info; %page; %include message_info; %page; %include send_mail_info; %page; %include mlsys_parse_ca_options; end send_message;  send_message_obsolete.pl1 11/08/84 0902.6rew 11/08/84 0805.7 101529 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* This module implements the following obsolete message facility commands: send_message_acknowledge (sma) send_message_express (smx) send_message_silent (sms) and the following subroutines: send_message_ send_message_acknowledge_ (send_message_$acknowledge) send_message_express_ (send_message_$express) send_message_$notify_mail */ /* Written 12/16/83 by Jim Lippard */ send_message_obsolete: procedure options (variable); return; dcl ME char (24); dcl (active_fnc_err_, com_err_, com_err_$suppress_name) entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl arg_count fixed bin; dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl arg char (arg_len) based (arg_ptr); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl dname char (168); dcl ename char (32); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl destination_arg char (168); dcl ioa_ entry () options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$user_input ptr ext static; dcl message_facility_$send_message entry (char (*), char (*), char (*), ptr, fixed bin (35)); dcl chars_read fixed bin (21); dcl old_message_ptr ptr; dcl old_message_len fixed bin (21); dcl message_ptr ptr; dcl message_len fixed bin (21); dcl message_space char (1600) aligned; dcl message char (message_len) based (message_ptr); dcl start_len fixed bin (21); dcl get_system_free_area_ entry () returns (ptr); dcl area_ptr ptr; dcl area area based (area_ptr); dcl user_info_$whoami entry (char (*), char (*), char (*)); dcl person char (22); dcl project char (9); dcl idx fixed bin; dcl (P_person, P_project, P_message) char (*) parameter; dcl P_code fixed bin (35) parameter; dcl brief bit (1) aligned; dcl destination bit (1) aligned; dcl message_allocated bit (1) aligned; dcl pathname bit (1) aligned; dcl (addr, after, before, length, null, rtrim, substr) builtin; dcl code fixed bin (35); dcl (error_table_$long_record, error_table_$messages_deferred, error_table_$messages_off, error_table_$no_append, error_table_$no_dir, error_table_$noentry, error_table_$no_info, error_table_$wakeup_denied) ext fixed bin (35); dcl TRUE bit (1) aligned internal static options (constant) init ("1"b); dcl FALSE bit (1) aligned internal static options (constant) init ("0"b); dcl DOT_NL char (2) aligned internal static options (constant) init (". "); dcl NL char (1) aligned internal static options (constant) init (" "); send_message_acknowledge: sma: entry; ME = "send_message_acknowledge"; call smo_initialize (); send_mail_info.acknowledge = TRUE; call smo_command (); return; send_message_express: smx: entry; ME = "send_message_express"; call smo_initialize (); send_mail_info.always_add = FALSE; call smo_command (); return; send_message_silent: sms: entry; ME = "send_message_silent"; call smo_initialize (); brief = TRUE; call smo_command (); return; send_message_: entry (P_person, P_project, P_message, P_code); call smo_initialize (); call smo_subroutine (); return; send_message_acknowledge_: acknowledge: entry (P_person, P_project, P_message, P_code); call smo_initialize (); send_mail_info.acknowledge = TRUE; call smo_subroutine (); return; send_message_express_: express: entry (P_person, P_project, P_message, P_code); call smo_initialize (); send_mail_info.always_add = FALSE; call smo_subroutine (); return; notify_mail: entry (P_person, P_project, P_code); call smo_initialize (); send_mail_info.notify = TRUE; send_mail_info.always_add = FALSE; call smo_subroutine (); return; smo_initialize: procedure (); /* initialize variables */ brief = FALSE; area_ptr = null (); call user_info_$whoami (person, "", ""); send_mail_info.version = send_mail_info_version_2; send_mail_info.sent_from = person; send_mail_info.wakeup = TRUE; send_mail_info.mbz1 = ""b; send_mail_info.always_add = TRUE; send_mail_info.never_add = FALSE; send_mail_info.notify = FALSE; send_mail_info.acknowledge = FALSE; send_mail_info.mbz = ""b; end smo_initialize; smo_command: procedure (); /* procedure for commands */ destination, message_allocated = FALSE; /* process arguments */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call active_fnc_err_ (code, ME); return; end; do idx = 1 to arg_count while (^destination); call cu_$arg_ptr (idx, arg_ptr, arg_len, (0)); if arg = "-pathname" | arg = "-pn" then do; /* pathname destination */ idx = idx + 1; if idx > arg_count then do; call com_err_ ((0), ME, "No value specified for -pathname."); return; end; call cu_$arg_ptr (idx, arg_ptr, arg_len, (0)); call expand_pathname_$add_suffix (arg, "mbx", dname, ename, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); return; end; destination_arg = pathname_ (dname, ename); destination, pathname = TRUE; end; else do; /* person.project or person project */ person = before (arg, "."); project = after (arg, "."); if project = "" then do; /* person project or project is missing */ idx = idx + 1; if idx <= arg_count then do; person = arg; call cu_$arg_ptr (idx, arg_ptr, arg_len, (0)); project = arg; end; else do; call com_err_$suppress_name ((0), ME, "Usage: ^a person.project {message} or:^5x^a -pathname path {message}", ME, ME); return; end; end; dname = ">udd>" || rtrim (project) || ">" || person; ename = rtrim (person) || ".mbx"; destination_arg = rtrim (person) || "." || project; destination = TRUE; pathname = FALSE; end; end; if ^destination then do; call com_err_$suppress_name ((0), ME, "Usage: ^a person.project {message} or:^5x^a -pathname path {message}", ME, ME); return; end; message_ptr = addr (message_space); message_len = length (message_space); message = ""; if idx <= arg_count then do; /* message on the line */ start_len = 1; do idx = idx to arg_count; call cu_$arg_ptr (idx, arg_ptr, arg_len, (0)); if start_len + arg_len > message_len then do; old_message_ptr = message_ptr; old_message_len = message_len; message_len = message_len + arg_len + length (message_space); if area_ptr = null () then area_ptr = get_system_free_area_ (); allocate message in (area) set (message_ptr); message_allocated = TRUE; message = substr (old_message_ptr -> message, 1, old_message_len); if old_message_len > length (message_space) then free old_message_ptr -> message in (area); end; substr (message, start_len, arg_len) = arg; start_len = start_len + arg_len + 1; substr (message, start_len - 1, 1) = " "; end; substr (message, start_len - 1, 1) = NL; call message_facility_$send_message (dname, ename, substr (message, 1, start_len - 1), addr (send_mail_info), code); if message_allocated then do; message_allocated = FALSE; free message in (area); end; end; else do; /* input mode */ send_mail_info.never_add = TRUE; call message_facility_$send_message (dname, ename, "", addr (send_mail_info), code); send_mail_info.never_add = FALSE; if code ^= 0 then if (code = error_table_$messages_off | code = error_table_$messages_deferred) then do; if ^send_mail_info.always_add then do; call com_err_ (code, ME, "^a", destination_arg); return; end; if ^send_mail_info.acknowledge & ^brief then call com_err_ (code, ME, "^a", destination_arg); code = 0; end; else if code = error_table_$no_info then do; if send_mail_info.acknowledge then call com_err_ (code, ME, "Messages to ^a cannot be acknowledged.", destination_arg); else if ^brief then call com_err_ (code, ME, "^a", destination_arg); code = 0; end; if code ^= 0 then goto SMO_ERROR; call ioa_ ("Input:"); /* input mode */ do while (code = 0); call iox_$get_line (iox_$user_input, message_ptr, message_len, chars_read, code); if code ^= 0 then if code = error_table_$long_record then do; call com_err_ (code, ME, "user_input"); code = 0; end; else do; call com_err_ (code, ME, "user_input"); return; end; else if substr (message, 1, chars_read) = DOT_NL then return; call message_facility_$send_message (dname, ename, substr (message, 1, chars_read), addr (send_mail_info), code); if code ^= 0 then if (code = error_table_$messages_off | code = error_table_$no_info | code = error_table_$messages_deferred) then code = 0; end; end; if code ^= 0 then do; SMO_ERROR: if code = error_table_$noentry | code = error_table_$no_dir then call com_err_ ((0), ME, "No mailbox^[ for^] ^a", ^pathname, destination_arg); else if code = error_table_$no_append then call com_err_ ((0), ME, "Insufficient access to add a message to^[ mailbox of^] ^a", ^pathname, destination_arg); else if ^send_mail_info.always_add then if ^brief then call ioa_ ("Not sent."); else ; else if code = error_table_$wakeup_denied then if ^brief then call com_err_ ((0), ME, "Insufficient access to send a wakeup to ^a", destination_arg); else ; else if (code = error_table_$messages_off | code = error_table_$messages_deferred) then if ^send_mail_info.acknowledge & ^brief then call com_err_ (code, ME, "^a", destination_arg); else ; else if code = error_table_$no_info then if send_mail_info.acknowledge & ^brief then call com_err_ (code, ME, "Messages to ^a cannot be acknowledged.", destination_arg); else ; else call com_err_ (code, ME, "^a", destination_arg); end; end smo_command; smo_subroutine: procedure (); /* procedure for subroutines */ dname = ">udd>" || rtrim (P_project) || ">" || P_person; ename = rtrim (P_person) || ".mbx"; if send_mail_info.notify then call message_facility_$send_message (dname, ename, "You have mail.", addr (send_mail_info), code); else call message_facility_$send_message (dname, ename, P_message, addr (send_mail_info), code); P_code = code; end smo_subroutine; %include send_mail_info; end send_message_obsolete; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved