/* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ifthenstmt,ifthendo,ifthen,^indnoniterdo,indcomtxt,^inditerdo,idind22 */ /* cv_links_to_mail_table: copies the information from the mailbox links directory into the Mail Table, which is its replacement */ /* Written: 11 August 1983 by B. Margolin */ cv_links_to_mail_table: proc (); /*** Automatic/Based ***/ dcl 1 alias_mte aligned like mail_table_entry; dcl area_ptr ptr; dcl arg char (arg_len) based (arg_ptr); dcl arg_count fixed bin; dcl arg_len fixed bin (21); dcl arg_ptr ptr; dcl code fixed bin (35); dcl dummy_ptr ptr; dcl 1 new_mte aligned like mail_table_entry; dcl new_name_explanation char (128); dcl no_query bit (1); dcl 1 old_mtre aligned like mail_table_raw_entry; dcl sci_ptr ptr; /*** Static ***/ dcl LINKS_NAME char (32) int static options (constant) init ("*.mbx"); dcl LOWERCASE char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UPPERCASE char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl WHOAMI char (22) int static options (constant) init ("cv_links_to_mail_table"); dcl VERSION char (3) int static options (constant) init ("1.0"); dcl ( error_table_$bad_arg, error_table_$badopt, error_table_$not_privileged ) fixed bin (35) ext static; dcl mlsys_data_$mailbox_link_directory char (168) unaligned external static; /*** Entries ***/ dcl com_err_ entry () options (variable); dcl command_query_$yes_no entry () options (variable); dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)); dcl mail_table_priv_$add entry (ptr, fixed bin (35)); dcl mail_table_priv_$get entry (char(*) var, ptr, fixed bin(35)); 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_$get_area entry (ptr, ptr, char (*), ptr); dcl ssu_$release_area entry (ptr, ptr); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); /*** Misc ***/ dcl (cleanup, linkage_error) condition; dcl (addr, binary, codeptr, divide, index, length, null, reverse, rtrim, substr) builtin; %page; %include mail_table_entry; %page; %include query_info; %page; %include star_structures; area_ptr, sci_ptr = null (); code = 0; on cleanup call cleanup_proc (); call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_cltmt, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Creating standalone subsystem invocation."); return; end; on linkage_error begin; call ssu_$abort_line (sci_ptr, error_table_$not_privileged, "Access to mail_table_priv_ gate is required."); end; dummy_ptr = codeptr (mail_table_priv_$add); revert linkage_error; call ssu_$arg_count (sci_ptr, arg_count); if arg_count > 1 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a {-no_query}", WHOAMI); if arg_count = 1 then do; call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len); if arg = "-no_query" | arg = "-nqy" then no_query = "1"b; else if index (arg, "-") = 1 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg); else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg); end; else no_query = "0"b; call ssu_$get_area (sci_ptr, null (), "star dir list", area_ptr); star_select_sw = star_LINKS_ONLY_WITH_LINK_PATHS; call hcs_$star_dir_list_ (mlsys_data_$mailbox_link_directory, LINKS_NAME, star_select_sw, area_ptr, star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Listing ^a in ^a.", LINKS_NAME, mlsys_data_$mailbox_link_directory); /*** Initialize some structures used below ***/ old_mtre.version = MAIL_TABLE_RAW_ENTRY_VERSION_1; old_mtre.mbz = ""b; alias_mte.version, new_mte.version = MAIL_TABLE_ENTRY_VERSION_1; query_info.version = query_info_version_6; query_info.explanation_ptr = addr (new_name_explanation); /* Fill in length after calling ioa_ */ /*** Rest of the query_info defaults are correct ***/ do star_linkx = 1 to star_link_count; call cv_link (star_links (star_linkx)); end; GLOBAL_EXIT: call cleanup_proc (); return; abort_cltmt: proc (); go to GLOBAL_EXIT; end abort_cltmt; cleanup_proc: proc (); if area_ptr ^= null () then call ssu_$release_area (sci_ptr, area_ptr); if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); return; end cleanup_proc; cv_link: proc (P_link); dcl 1 P_link parameter aligned like star_links; /*** Automatic ***/ dcl buffer char (256); dcl buffer_used fixed bin (21); dcl case_ins_lookup fixed bin; dcl case_sens_lookup fixed bin; dcl code fixed bin (35); dcl dummy_address_ptr ptr; dcl link_address_ptr ptr; dcl link_name char (32) varying; dcl link_target_dname char (168); dcl link_target_ename char (32); dcl mte_address_ptr ptr; dcl name char (32) varying; dcl reverse_name char (32); dcl trying_new_name bit (1); /*** Static ***/ dcl ( FOUND init (1), NOT_FOUND init (2), AMBIGUOUS init (3) ) fixed bin int static options (constant); dcl ( error_table_$id_not_found, mlsys_et_$ambiguous_address ) fixed bin (35) ext static; /*** Entries ***/ dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl mail_system_$compare_addresses entry (ptr, ptr, fixed bin (35)) returns (bit (1) aligned); dcl mail_system_$create_forum_address entry (char (*), char (*), char (*) var, char (*) var, ptr, fixed bin (35)); dcl mail_system_$create_mailbox_address entry (char (*), char (*), char (*) var, char (*) var, ptr, fixed bin (35)); dcl mail_system_$create_mailing_list_address entry (char (*), char (*), char (*), char (*) var, char (*) var, ptr, fixed bin (35)); dcl mail_system_$create_user_mailbox_address entry (char (*) var, char (*) var, char (*) var, ptr, fixed bin (35)); dcl mail_system_$free_address entry (ptr, fixed bin (35)); dcl mail_table_$get entry (char (*) var, ptr, char (*), fixed bin (35)); dcl mail_table_priv_$get_raw_by_name entry (char (*) var, ptr, fixed bin (35)); dcl mlsys_utils_$format_address_field entry (char (*) var, ptr, fixed bin, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl mlsys_utils_$parse_address_text entry (char (*), ptr, fixed bin (35)); dcl ssu_$print_message entry () options (variable); code = 0; buffer_used = 0; /* Haven't yet formatted the link target address */ trying_new_name = "0"b; link_name = rtrim (star_list_names (P_link.nindex)); call strip_mbx_suffix (star_list_names (P_link.nindex), name); /* remove suffix */ link_address_ptr, mte_address_ptr = null (); /* For cleanup handler */ on cleanup call free_addresses (); CV_LINK_NEW_NAME: /* come from query_add */ call mail_table_priv_$get_raw_by_name (name, addr (old_mtre), code); if code = 0 then do; case_sens_lookup = FOUND; if length (old_mtre.mailing_address) > 0 then do; call mlsys_utils_$parse_address_text ((old_mtre.mailing_address), mte_address_ptr, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Parsing address in Mail Table entry for ^a: ^a; skipping to next link.", name, old_mtre.mailing_address); call abort_cv_link (); end; end; else if length (old_mtre.default_project) > 0 then do; call mail_system_$create_user_mailbox_address (old_mtre.name || "." || old_mtre.default_project, "", "", mte_address_ptr, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Creating user mailbox address for Mail Table entry ""^a"" which^/has the primary name ""^a"" and the default project ""^a""; skipping to next link." , name, old_mtre.name, old_mtre.default_project); call abort_cv_link (); end; end; /*** else we just leave it null ***/ end; else if code = error_table_$id_not_found then case_sens_lookup = NOT_FOUND; else do; call ssu_$print_message (sci_ptr, code, "Looking up Mail Table entry for ^a, case sensitively.", name); call abort_cv_link (); end; if case_sens_lookup = FOUND then case_ins_lookup = FOUND; else do; call mail_table_$get (name, mte_address_ptr, (""), code); if code = 0 then case_ins_lookup = FOUND; else if code = mlsys_et_$ambiguous_address then case_ins_lookup = AMBIGUOUS; else if code = error_table_$id_not_found then case_ins_lookup = NOT_FOUND; else do; call ssu_$print_message (sci_ptr, code, "Looking up Mail Table entry for ^a, case insensitively.", name); call abort_cv_link (); end; code = 0; end; /*** Get the address that the link points to ***/ if link_address_ptr = null () then if substr (star_link_pathname, 1, length (">FORWARD>")) = ">FORWARD>" then do; call mlsys_utils_$parse_address_text (substr (star_link_pathname, length (">FORWARD>") + 1), link_address_ptr, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Parsing address in link ^a: ^a; skipping to next link.", link_name, star_link_pathname); call abort_cv_link (); end; end; else do; call expand_pathname_ (star_link_pathname, link_target_dname, link_target_ename, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Expanding pathname of target of link ^a: ^a; skipping to next link.", link_name, star_link_pathname); call abort_cv_link (); end; reverse_name = reverse (rtrim (link_target_ename)); if index (reverse_name, reverse (".mbx")) = 1 then call mail_system_$create_mailbox_address (link_target_dname, link_target_ename, "", "", link_address_ptr, code); else if index (reverse_name, reverse (".mls")) = 1 then call mail_system_$create_mailing_list_address (link_target_dname, link_target_ename, "", "", "", link_address_ptr, code); else if index (reverse_name, reverse (".control")) = 1 | index (reverse_name, reverse (".forum")) = 1 then call mail_system_$create_forum_address (link_target_dname, link_target_ename, "", "", link_address_ptr, code); else do; call ssu_$print_message (sci_ptr, 0, "Unrecognizable link target for ^a: ^a; skipping to next link.", link_name, star_link_pathname); call abort_cv_link (); end; if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Creating address for link ^a to ^a; skipping to next link.", link_name, star_link_pathname) ; call abort_cv_link (); end; end; /*** Now decide if we want to add the entry and aliases ***/ /* Here is how this heuristic works: Calling mail_table_priv_$get_raw_by_name tells us if there is an exact match in the Mail Table. This information is in case_sens_lookup, which can either be FOUND or NOT_FOUND. Calling mail_table_$get tells us if there is a possibly-inexact match, putting the information in case_ins_lookup. FOUND means there is exactly one case-insensitive match, NOT_FOUND means there are none, and AMBIGUOUS means there are more than one. Here are enumerated the possible combinations and their meanings: */ /*^ # sens ins meaning - ---- --- ------- 1 FOUND FOUND We have an exact match to an entry, but there may be other inexact matches. If the existing Mail Table address and the link targets agree, then add the link's addnames as aliases. 2 NOT_FOUND FOUND We have an inexact match to a unique Mail Table entry. Adding the entry would create an ambiguity. If the existing Mail Table address and link targets agree then add the addnames as aliases. 3 FOUND NOT_FOUND ** Can't happen ** 4 NOT_FOUND NOT_FOUND Simple case: there is no such entry in the Mail Table, so add it and add the addnames as aliases. 5 FOUND AMBIGUOUS ** Can't happen ** 6 NOT_FOUND AMBIGUOUS We have an inexact match to several Mail Table entries. Adding this would extend an existing ambiguity. Do so only if the user says so. */ /* In cases 1 and 2, mte_address_ptr will be the mailing address from the Mail Table entry that was found, for use in comparing addresses. If the links directory contains the following names: FORD RK FOO ford and the Mail Table contains: Ford FORD rk then the cases are as follows: 1: FORD 2: RK 4: FOO 6: ford */ /*** If there is an exact match already in the Mail Table and they both point to the same place, then use the addnames as aliases ***/ if case_sens_lookup = FOUND then /* Case 1 */ if mail_system_$compare_addresses (mte_address_ptr, link_address_ptr, (0)) then call add_aliases (); else call query_add (); /*** There are no matches, so just add it. ***/ else if case_sens_lookup = NOT_FOUND & case_ins_lookup = NOT_FOUND then do; /* Case 4 */ call add_entry (); call add_aliases (); end; /*** We have an inexact match to a single entry, but they are equivalent, so add the aliases. ***/ else if case_ins_lookup = FOUND then /* Case 2 */ if mail_system_$compare_addresses (mte_address_ptr, link_address_ptr, (0)) then call add_aliases (); else call query_add (); /*** We have an inexact match, and adding it would extend or create an ambiguity. Query the user. ***/ else call query_add (); /* Cases 2 & 6 */ ABORT_CV_LINK: call free_addresses (); return; abort_cv_link: proc (); go to ABORT_CV_LINK; end abort_cv_link; free_addresses: proc (); if link_address_ptr ^= null () then call mail_system_$free_address (link_address_ptr, (0)); if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0)); return; end free_addresses; query_add: proc (); dcl command_query_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl old_address_string char (256) varying; dcl yes_sw bit (1); if no_query then do; /* He wants me to think for myself */ call ssu_$print_message (sci_ptr, 0, "Link ^a not converted because of case-insensitive Mail Table conflict.", link_name); call abort_cv_link (); end; call format_link_address (); /* Fills buffer */ if case_sens_lookup = FOUND then do; /* Addresses don't match */ if length (old_mtre.mailing_address) > 0 then old_address_string = old_mtre.mailing_address; else old_address_string = old_mtre.name || "." || old_mtre.default_project; call command_query_$yes_no (yes_sw, 0, WHOAMI, "The link ^a has the mailing address ^a." || "^/The Mail Table entry ^a has the mailing address ^a." || "^/Should the link target replace this Mail Table address?" || "^/Answer ""no"" to specify another Mail Table entry name to use.", "The link ^a^s does not have the same mailing address as" || "^/the the Mail Table entry ^a^s; replace the Mail Table entry?", link_name, substr (buffer, 1, buffer_used), name, old_address_string); if yes_sw then call replace_entry (); end; else do; call command_query_$yes_no (yes_sw, 0, WHOAMI, "The ^[specified name ^a^;link ^a.mbx^], address ^a, matches ^[a Mail Table entry^;several Mail Table entries^] case-insensitively." || "^/Should it be added to the Mail Table anyway, ^[creating an^;adding to the^] ambiguity?" || "^/Answer ""no"" to specify another Mail Table entry name to use.", "The ^[name ^a^;link ^a.mbx^] conflicts case-insensitively" || "^/with ^s^[a^;several^] Mail Table entr^[y^;ies^]; add it anyway?", trying_new_name, name, substr (buffer, 1, buffer_used), (case_ins_lookup = FOUND), (case_ins_lookup = FOUND)); if yes_sw then call add_entry_force (); end; if yes_sw then do; call add_aliases (); return; end; /*** Query about a new name ***/ call command_query_$yes_no (yes_sw, 0, WHOAMI, "Would you like to specify a Mail Table name to try instead of ^a, for the link ^a?", "Would you like to specify the Mail Table entry corresponding to the link ^s^a?", name, link_name); if ^yes_sw then return; call ioa_$rsnnl ("Please specify the Mail Table entry name to use instead of ^a.", new_name_explanation, query_info.explanation_len, name); /*** query_info.explanation_ptr already points there ***/ call command_query_ (addr (query_info), name, WHOAMI, "New name:"); trying_new_name = "1"b; if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0)); /* So we can try a new one */ go to CV_LINK_NEW_NAME; end query_add; add_entry: proc (); dcl code fixed bin (35); dcl mail_table_priv_$add entry (ptr, bit (1), fixed bin (35)); dcl ok_to_add bit (1); if trying_new_name then do; call command_query_$yes_no (ok_to_add, error_table_$id_not_found, WHOAMI, "The name ""^a"" is not the name of an existing Mail Table entry.^/Do you really wish to create a new entry with this name?" , "Create a new entry?", name); if ^ok_to_add then return; end; add_entry_force: entry (); new_mte.name = name; call format_link_address (); new_mte.mailing_address = substr (buffer, 1, buffer_used); new_mte.default_project, new_mte.acs_path.dir, new_mte.acs_path.entry = ""; /*** new_mte.version was initialized out of the loop ***/ call mail_table_priv_$add (addr (new_mte), "0"b, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Creating the Mail Table entry ^a.", name); call abort_cv_link (); end; return; end add_entry; add_aliases: proc (); dcl addname_idx fixed bin; dcl alias char (32) varying; dcl check_alias char (32) varying; dcl check_idx fixed bin; dcl code fixed bin (35); dcl error_table_$id_already_exists fixed bin (35) ext static; dcl mail_table_priv_$add_alias entry (char (*) var, char (*) var, bit (1), fixed bin (35)); do addname_idx = (P_link.nindex + 1) to (P_link.nindex + P_link.nnames - 1); /* Skip the first name */ call strip_mbx_suffix (star_list_names (addname_idx), alias); /*** First a quick check ***/ do check_idx = P_link.nindex to addname_idx - 1; call strip_mbx_suffix (star_list_names (check_idx), check_alias); if length (check_alias) = length (alias) then if translate (check_alias, UPPERCASE, LOWERCASE) = translate (alias, UPPERCASE, LOWERCASE) then go to NEXT_ADDNAME; /* The addname is just case-different, so skip it */ end; call mail_table_priv_$get (alias, addr (alias_mte), code); if code ^= error_table_$id_not_found then do; if (code = 0) & (alias_mte.name = old_mtre.name) then go to NEXT_ADDNAME; /* It's already HIS alias, so don't complain */ else if code = 0 | code = mlsys_et_$ambiguous_address then call ssu_$print_message (sci_ptr, error_table_$id_already_exists, "The addname ^a.mbx will not be added as an alias for ^a.", alias, name); else call ssu_$print_message (sci_ptr, code, "Retrieving Mail Table info for ""^a"". It will not be added as an alias for ^a.", alias, name); code = 0; go to NEXT_ADDNAME; end; /*** OK, add the alias ***/ code = 0; call mail_table_priv_$add_alias (name, alias, "0"b, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Adding ""^a"" as an alias for ^a.", alias, name); code = 0; end; NEXT_ADDNAME: end; return; end add_aliases; replace_entry: proc (); dcl code fixed bin (35); dcl mail_table_priv_$update entry (ptr, bit (1), fixed bin (35)); call format_link_address (); new_mte = old_mtre, by name; new_mte.version = MAIL_TABLE_ENTRY_VERSION_1; /* That's the only difference */ new_mte.mailing_address = substr (buffer, 1, buffer_used); call mail_table_priv_$update (addr (new_mte), "0"b, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Updating the mailing address for ^a. Skipping to next link.", name); call abort_cv_link (); end; return; end replace_entry; format_link_address: proc (); if buffer_used ^= 0 then return; /* Already formatted it */ call mlsys_utils_$format_address_field ("", link_address_ptr, -1, addr (buffer), length (buffer), buffer_used, code); if code ^= 0 then do; call ssu_$print_message (sci_ptr, code, "Formatting address for link ^a.mbx: ^a; skipping to next link.", link_name, star_link_pathname); call abort_cv_link (); end; return; end format_link_address; strip_mbx_suffix: proc (P_suffixed_name, P_stripped_name); dcl P_suffixed_name char (*); dcl P_stripped_name char (*) varying; P_stripped_name = rtrim (P_suffixed_name); P_stripped_name = substr (P_stripped_name, 1, length (P_stripped_name) - length (".mbx")); return; end strip_mbx_suffix; end cv_link; end cv_links_to_mail_table; */ ----------------------------------------------------------- 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 */