1
2
3
4
5
6
7
8
9
10
11
12
13
14 cv_links_to_mail_table:
15 proc ();
16
17
18
19 dcl 1 alias_mte aligned like mail_table_entry;
20 dcl area_ptr ptr;
21 dcl arg char (arg_len) based (arg_ptr);
22 dcl arg_count fixed bin;
23 dcl arg_len fixed bin (21);
24 dcl arg_ptr ptr;
25 dcl code fixed bin (35);
26 dcl dummy_ptr ptr;
27 dcl 1 new_mte aligned like mail_table_entry;
28 dcl new_name_explanation char (128);
29 dcl no_query bit (1);
30 dcl 1 old_mtre aligned like mail_table_raw_entry;
31 dcl sci_ptr ptr;
32
33
34
35 dcl LINKS_NAME char (32) int static options (constant) init ("*.mbx");
36 dcl LOWERCASE char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
37 dcl UPPERCASE char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
38 dcl WHOAMI char (22) int static options (constant) init ("cv_links_to_mail_table");
39 dcl VERSION char (3) int static options (constant) init ("1.0");
40 dcl (
41 error_table_$bad_arg,
42 error_table_$badopt,
43 error_table_$not_privileged
44 ) fixed bin (35) ext static;
45 dcl mlsys_data_$mailbox_link_directory
46 char (168) unaligned external static;
47
48
49
50 dcl com_err_ entry () options (variable);
51 dcl command_query_$yes_no entry () options (variable);
52 dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr,
53 fixed bin (35));
54 dcl mail_table_priv_$add entry (ptr, fixed bin (35));
55 dcl mail_table_priv_$get entry (char(*) var, ptr, fixed bin(35));
56 dcl ssu_$abort_line entry () options (variable);
57 dcl ssu_$arg_count entry (ptr, fixed bin);
58 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
59 dcl ssu_$destroy_invocation
60 entry (ptr);
61 dcl ssu_$get_area entry (ptr, ptr, char (*), ptr);
62 dcl ssu_$release_area entry (ptr, ptr);
63 dcl ssu_$standalone_invocation
64 entry (ptr, char (*), char (*), ptr, entry, fixed bin (35));
65
66
67 dcl (cleanup, linkage_error)
68 condition;
69 dcl (addr, binary, codeptr, divide, index, length, null, reverse, rtrim, substr)
70 builtin;
71 %page;
72 %include mail_table_entry;
73 %page;
74 %include query_info;
75 %page;
76 %include star_structures;
77 ^L
78 area_ptr, sci_ptr = null ();
79 code = 0;
80 on cleanup call cleanup_proc ();
81 call ssu_$standalone_invocation (sci_ptr, WHOAMI, VERSION, null (), abort_cltmt, code);
82 if code ^= 0 then do;
83 call com_err_ (code, WHOAMI, "Creating standalone subsystem invocation.");
84 return;
85 end;
86
87 on linkage_error
88 begin;
89 call ssu_$abort_line (sci_ptr, error_table_$not_privileged,
90 "Access to mail_table_priv_ gate is required.");
91 end;
92 dummy_ptr = codeptr (mail_table_priv_$add);
93 revert linkage_error;
94
95 call ssu_$arg_count (sci_ptr, arg_count);
96 if arg_count > 1 then call ssu_$abort_line (sci_ptr, 0, "Usage: ^a {-no_query}", WHOAMI);
97 if arg_count = 1 then do;
98 call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_len);
99 if arg = "-no_query" | arg = "-nqy" then no_query = "1"b;
100 else if index (arg, "-") = 1 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg);
101 else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg);
102 end;
103 else no_query = "0"b;
104
105 call ssu_$get_area (sci_ptr, null (), "star dir list", area_ptr);
106
107 star_select_sw = star_LINKS_ONLY_WITH_LINK_PATHS;
108 call hcs_$star_dir_list_ (mlsys_data_$mailbox_link_directory, LINKS_NAME, star_select_sw, area_ptr,
109 star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code);
110 if code ^= 0 then
111 call ssu_$abort_line (sci_ptr, code, "Listing ^a in ^a.", LINKS_NAME, mlsys_data_$mailbox_link_directory);
112
113
114 old_mtre.version = MAIL_TABLE_RAW_ENTRY_VERSION_1;
115 old_mtre.mbz = ""b;
116 alias_mte.version, new_mte.version = MAIL_TABLE_ENTRY_VERSION_1;
117 query_info.version = query_info_version_6;
118 query_info.explanation_ptr = addr (new_name_explanation);
119
120
121
122 do star_linkx = 1 to star_link_count;
123 call cv_link (star_links (star_linkx));
124 end;
125
126 GLOBAL_EXIT:
127 call cleanup_proc ();
128 return;
129
130 abort_cltmt:
131 proc ();
132
133 go to GLOBAL_EXIT;
134
135 end abort_cltmt;
136
137 cleanup_proc:
138 proc ();
139
140 if area_ptr ^= null () then call ssu_$release_area (sci_ptr, area_ptr);
141 if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr);
142 return;
143
144 end cleanup_proc;
145
146 cv_link:
147 proc (P_link);
148
149 dcl 1 P_link parameter aligned like star_links;
150
151
152
153 dcl buffer char (256);
154 dcl buffer_used fixed bin (21);
155 dcl case_ins_lookup fixed bin;
156 dcl case_sens_lookup fixed bin;
157 dcl code fixed bin (35);
158 dcl dummy_address_ptr ptr;
159 dcl link_address_ptr ptr;
160 dcl link_name char (32) varying;
161 dcl link_target_dname char (168);
162 dcl link_target_ename char (32);
163 dcl mte_address_ptr ptr;
164 dcl name char (32) varying;
165 dcl reverse_name char (32);
166 dcl trying_new_name bit (1);
167
168
169
170 dcl (
171 FOUND init (1),
172 NOT_FOUND init (2),
173 AMBIGUOUS init (3)
174 ) fixed bin int static options (constant);
175 dcl (
176 error_table_$id_not_found,
177 mlsys_et_$ambiguous_address
178 ) fixed bin (35) ext static;
179
180
181
182 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
183 dcl mail_system_$compare_addresses
184 entry (ptr, ptr, fixed bin (35)) returns (bit (1) aligned);
185 dcl mail_system_$create_forum_address
186 entry (char (*), char (*), char (*) var, char (*) var, ptr, fixed bin (35));
187 dcl mail_system_$create_mailbox_address
188 entry (char (*), char (*), char (*) var, char (*) var, ptr, fixed bin (35));
189 dcl mail_system_$create_mailing_list_address
190 entry (char (*), char (*), char (*), char (*) var, char (*) var, ptr, fixed bin (35));
191 dcl mail_system_$create_user_mailbox_address
192 entry (char (*) var, char (*) var, char (*) var, ptr, fixed bin (35));
193 dcl mail_system_$free_address
194 entry (ptr, fixed bin (35));
195 dcl mail_table_$get entry (char (*) var, ptr, char (*), fixed bin (35));
196 dcl mail_table_priv_$get_raw_by_name
197 entry (char (*) var, ptr, fixed bin (35));
198 dcl mlsys_utils_$format_address_field
199 entry (char (*) var, ptr, fixed bin, ptr, fixed bin (21), fixed bin (21),
200 fixed bin (35));
201 dcl mlsys_utils_$parse_address_text
202 entry (char (*), ptr, fixed bin (35));
203 dcl ssu_$print_message entry () options (variable);
204
205 code = 0;
206 buffer_used = 0;
207 trying_new_name = "0"b;
208 link_name = rtrim (star_list_names (P_link.nindex));
209 call strip_mbx_suffix (star_list_names (P_link.nindex), name);
210
211 link_address_ptr, mte_address_ptr = null ();
212
213 on cleanup call free_addresses ();
214
215 CV_LINK_NEW_NAME:
216 call mail_table_priv_$get_raw_by_name (name, addr (old_mtre), code);
217 if code = 0 then do;
218 case_sens_lookup = FOUND;
219 if length (old_mtre.mailing_address) > 0 then do;
220 call mlsys_utils_$parse_address_text ((old_mtre.mailing_address), mte_address_ptr, code);
221 if code ^= 0 then do;
222 call ssu_$print_message (sci_ptr, code,
223 "Parsing address in Mail Table entry for ^a: ^a; skipping to next link.", name,
224 old_mtre.mailing_address);
225 call abort_cv_link ();
226 end;
227 end;
228 else if length (old_mtre.default_project) > 0 then do;
229 call mail_system_$create_user_mailbox_address (old_mtre.name || "." || old_mtre.default_project, "",
230 "", mte_address_ptr, code);
231 if code ^= 0 then do;
232 call ssu_$print_message (sci_ptr, code,
233 "Creating user mailbox address for Mail Table entry ""^a"" which^/has the primary name ""^a"" and the default project ""^a""; skipping to next link."
234 , name, old_mtre.name, old_mtre.default_project);
235 call abort_cv_link ();
236 end;
237 end;
238
239 end;
240 else if code = error_table_$id_not_found then case_sens_lookup = NOT_FOUND;
241 else do;
242 call ssu_$print_message (sci_ptr, code, "Looking up Mail Table entry for ^a, case sensitively.", name);
243 call abort_cv_link ();
244 end;
245
246 if case_sens_lookup = FOUND then
247 case_ins_lookup = FOUND;
248 else do;
249 call mail_table_$get (name, mte_address_ptr, (""), code);
250 if code = 0 then case_ins_lookup = FOUND;
251 else if code = mlsys_et_$ambiguous_address then case_ins_lookup = AMBIGUOUS;
252 else if code = error_table_$id_not_found then case_ins_lookup = NOT_FOUND;
253 else do;
254 call ssu_$print_message (sci_ptr, code, "Looking up Mail Table entry for ^a, case insensitively.",
255 name);
256 call abort_cv_link ();
257 end;
258 code = 0;
259 end;
260
261
262 if link_address_ptr = null () then
263 if substr (star_link_pathname, 1, length (">FORWARD>")) = ">FORWARD>" then do;
264 call mlsys_utils_$parse_address_text (substr (star_link_pathname, length (">FORWARD>") + 1),
265 link_address_ptr, code);
266 if code ^= 0 then do;
267 call ssu_$print_message (sci_ptr, code, "Parsing address in link ^a: ^a; skipping to next link.",
268 link_name, star_link_pathname);
269 call abort_cv_link ();
270 end;
271 end;
272 else do;
273 call expand_pathname_ (star_link_pathname, link_target_dname, link_target_ename, code);
274 if code ^= 0 then do;
275 call ssu_$print_message (sci_ptr, code,
276 "Expanding pathname of target of link ^a: ^a; skipping to next link.", link_name,
277 star_link_pathname);
278 call abort_cv_link ();
279 end;
280 reverse_name = reverse (rtrim (link_target_ename));
281 if index (reverse_name, reverse (".mbx")) = 1 then
282 call mail_system_$create_mailbox_address (link_target_dname, link_target_ename, "", "", link_address_ptr, code);
283 else if index (reverse_name, reverse (".mls")) = 1 then
284 call mail_system_$create_mailing_list_address (link_target_dname, link_target_ename, "", "", "", link_address_ptr,
285 code);
286 else if index (reverse_name, reverse (".control")) = 1 | index (reverse_name, reverse (".forum")) = 1
287 then call mail_system_$create_forum_address (link_target_dname, link_target_ename, "", "", link_address_ptr, code);
288 else do;
289 call ssu_$print_message (sci_ptr, 0,
290 "Unrecognizable link target for ^a: ^a; skipping to next link.", link_name,
291 star_link_pathname);
292 call abort_cv_link ();
293 end;
294 if code ^= 0 then do;
295 call ssu_$print_message (sci_ptr, code,
296 "Creating address for link ^a to ^a; skipping to next link.", link_name, star_link_pathname)
297 ;
298 call abort_cv_link ();
299 end;
300 end;
301 ^L
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359 if case_sens_lookup = FOUND then
360 if mail_system_$compare_addresses (mte_address_ptr, link_address_ptr, (0)) then
361 call add_aliases ();
362 else call query_add ();
363
364 else if case_sens_lookup = NOT_FOUND & case_ins_lookup = NOT_FOUND then do;
365
366 call add_entry ();
367 call add_aliases ();
368 end;
369
370
371 else if case_ins_lookup = FOUND then
372 if mail_system_$compare_addresses (mte_address_ptr, link_address_ptr, (0)) then
373 call add_aliases ();
374 else call query_add ();
375
376
377 else call query_add ();
378
379 ABORT_CV_LINK:
380 call free_addresses ();
381 return;
382
383 abort_cv_link:
384 proc ();
385
386 go to ABORT_CV_LINK;
387
388 end abort_cv_link;
389
390 free_addresses:
391 proc ();
392
393 if link_address_ptr ^= null () then call mail_system_$free_address (link_address_ptr, (0));
394 if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0));
395 return;
396
397 end free_addresses;
398
399 query_add:
400 proc ();
401
402 dcl command_query_ entry () options (variable);
403 dcl ioa_$rsnnl entry () options (variable);
404 dcl old_address_string char (256) varying;
405 dcl yes_sw bit (1);
406
407 if no_query then do;
408 call ssu_$print_message (sci_ptr, 0,
409 "Link ^a not converted because of case-insensitive Mail Table conflict.", link_name);
410 call abort_cv_link ();
411 end;
412
413 call format_link_address ();
414 if case_sens_lookup = FOUND then do;
415 if length (old_mtre.mailing_address) > 0 then
416 old_address_string = old_mtre.mailing_address;
417 else old_address_string = old_mtre.name || "." || old_mtre.default_project;
418 call command_query_$yes_no (yes_sw, 0, WHOAMI,
419 "The link ^a has the mailing address ^a."
420 || "^/The Mail Table entry ^a has the mailing address ^a."
421 || "^/Should the link target replace this Mail Table address?"
422 || "^/Answer ""no"" to specify another Mail Table entry name to use.",
423 "The link ^a^s does not have the same mailing address as"
424 || "^/the the Mail Table entry ^a^s; replace the Mail Table entry?", link_name, substr (buffer, 1, buffer_used), name,
425 old_address_string);
426 if yes_sw then call replace_entry ();
427 end;
428 else do;
429 call command_query_$yes_no (yes_sw, 0, WHOAMI,
430 "The ^[specified name ^a^;link ^a.mbx^], address ^a, matches ^[a Mail Table entry^;several Mail Table entries^] case-insensitively."
431 || "^/Should it be added to the Mail Table anyway, ^[creating an^;adding to the^] ambiguity?"
432 || "^/Answer ""no"" to specify another Mail Table entry name to use.",
433 "The ^[name ^a^;link ^a.mbx^] conflicts case-insensitively"
434 || "^/with ^s^[a^;several^] Mail Table entr^[y^;ies^]; add it anyway?", trying_new_name, name, substr (buffer, 1, buffer_used),
435 (case_ins_lookup = FOUND), (case_ins_lookup = FOUND));
436 if yes_sw then call add_entry_force ();
437 end;
438 if yes_sw then do;
439 call add_aliases ();
440 return;
441 end;
442
443
444 call command_query_$yes_no (yes_sw, 0, WHOAMI,
445 "Would you like to specify a Mail Table name to try instead of ^a, for the link ^a?",
446 "Would you like to specify the Mail Table entry corresponding to the link ^s^a?", name, link_name);
447 if ^yes_sw then return;
448 call ioa_$rsnnl ("Please specify the Mail Table entry name to use instead of ^a.", new_name_explanation,
449 query_info.explanation_len, name);
450
451 call command_query_ (addr (query_info), name, WHOAMI, "New name:");
452 trying_new_name = "1"b;
453 if mte_address_ptr ^= null () then call mail_system_$free_address (mte_address_ptr, (0));
454
455 go to CV_LINK_NEW_NAME;
456
457 end query_add;
458
459 add_entry:
460 proc ();
461
462 dcl code fixed bin (35);
463 dcl mail_table_priv_$add entry (ptr, bit (1), fixed bin (35));
464 dcl ok_to_add bit (1);
465
466 if trying_new_name then do;
467 call command_query_$yes_no (ok_to_add, error_table_$id_not_found, WHOAMI,
468 "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?"
469 , "Create a new entry?", name);
470 if ^ok_to_add then return;
471 end;
472
473 add_entry_force:
474 entry ();
475
476 new_mte.name = name;
477 call format_link_address ();
478 new_mte.mailing_address = substr (buffer, 1, buffer_used);
479 new_mte.default_project, new_mte.acs_path.dir, new_mte.acs_path.entry = "";
480
481 call mail_table_priv_$add (addr (new_mte), "0"b, code);
482 if code ^= 0 then do;
483 call ssu_$print_message (sci_ptr, code, "Creating the Mail Table entry ^a.", name);
484 call abort_cv_link ();
485 end;
486 return;
487
488 end add_entry;
489
490 add_aliases:
491 proc ();
492
493 dcl addname_idx fixed bin;
494 dcl alias char (32) varying;
495 dcl check_alias char (32) varying;
496 dcl check_idx fixed bin;
497 dcl code fixed bin (35);
498 dcl error_table_$id_already_exists
499 fixed bin (35) ext static;
500 dcl mail_table_priv_$add_alias
501 entry (char (*) var, char (*) var, bit (1), fixed bin (35));
502
503 do addname_idx = (P_link.nindex + 1) to (P_link.nindex + P_link.nnames - 1);
504
505 call strip_mbx_suffix (star_list_names (addname_idx), alias);
506
507
508 do check_idx = P_link.nindex to addname_idx - 1;
509 call strip_mbx_suffix (star_list_names (check_idx), check_alias);
510 if length (check_alias) = length (alias) then
511 if translate (check_alias, UPPERCASE, LOWERCASE) = translate (alias, UPPERCASE, LOWERCASE) then
512 go to NEXT_ADDNAME;
513 end;
514
515 call mail_table_priv_$get (alias, addr (alias_mte), code);
516 if code ^= error_table_$id_not_found then do;
517 if (code = 0) & (alias_mte.name = old_mtre.name) then
518 go to NEXT_ADDNAME;
519 else if code = 0 | code = mlsys_et_$ambiguous_address then
520 call ssu_$print_message (sci_ptr, error_table_$id_already_exists,
521 "The addname ^a.mbx will not be added as an alias for ^a.", alias, name);
522 else call ssu_$print_message (sci_ptr, code,
523 "Retrieving Mail Table info for ""^a"". It will not be added as an alias for ^a.", alias,
524 name);
525 code = 0;
526 go to NEXT_ADDNAME;
527 end;
528
529 code = 0;
530 call mail_table_priv_$add_alias (name, alias, "0"b, code);
531 if code ^= 0 then do;
532 call ssu_$print_message (sci_ptr, code, "Adding ""^a"" as an alias for ^a.", alias, name);
533 code = 0;
534 end;
535 NEXT_ADDNAME:
536 end;
537 return;
538
539 end add_aliases;
540
541 replace_entry:
542 proc ();
543
544 dcl code fixed bin (35);
545 dcl mail_table_priv_$update
546 entry (ptr, bit (1), fixed bin (35));
547
548 call format_link_address ();
549 new_mte = old_mtre, by name;
550 new_mte.version = MAIL_TABLE_ENTRY_VERSION_1;
551 new_mte.mailing_address = substr (buffer, 1, buffer_used);
552 call mail_table_priv_$update (addr (new_mte), "0"b, code);
553 if code ^= 0 then do;
554 call ssu_$print_message (sci_ptr, code, "Updating the mailing address for ^a. Skipping to next link.",
555 name);
556 call abort_cv_link ();
557 end;
558 return;
559
560 end replace_entry;
561
562 format_link_address:
563 proc ();
564
565 if buffer_used ^= 0 then return;
566 call mlsys_utils_$format_address_field ("", link_address_ptr, -1, addr (buffer), length (buffer), buffer_used,
567 code);
568 if code ^= 0 then do;
569 call ssu_$print_message (sci_ptr, code, "Formatting address for link ^a.mbx: ^a; skipping to next link.",
570 link_name, star_link_pathname);
571 call abort_cv_link ();
572 end;
573 return;
574
575 end format_link_address;
576
577 strip_mbx_suffix:
578 proc (P_suffixed_name, P_stripped_name);
579
580 dcl P_suffixed_name char (*);
581 dcl P_stripped_name char (*) varying;
582
583 P_stripped_name = rtrim (P_suffixed_name);
584 P_stripped_name = substr (P_stripped_name, 1, length (P_stripped_name) - length (".mbx"));
585 return;
586
587 end strip_mbx_suffix;
588
589 end cv_link;
590
591 end cv_links_to_mail_table;