COMPILATION LISTING OF SEGMENT mlsys_parse_text_ Compiled by: Multics PL/I Compiler, Release 30, of February 16, 1988 Compiled at: Honeywell Bull, Phoenix AZ, SysM Compiled on: 07/26/88 1011.7 mst Tue Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Bull Inc., 1988 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1983 * 6* * * 7* *********************************************************** */ 8 9 10 11 /****^ HISTORY COMMENTS: 12* 1) change(83-07-01,Palter), approve(), audit(), install(): 13* Pre-hcom comments: 14* Created: July 1983 by G. Palter from mlsys_cv_old_r1_msg_ and mlsys_parse_ 15* Modified: March 1984 by G. Palter to fix the following mail system errors: 16* #0415 -- read_mail, print_mail, and have_mail do not reject starnames as invalid mailbox specifications 17* #0417 -- the offset within the message text of an invalid field as returned by mlsys_utils_$parse_message_text does 18* not take into account the blank lines which the parser allows to appear before the message header. As a result, 19* error messages produced by send_mail, etc. will appear to truncate the contents of the invalid field 20* #0432 -- when converting a forwarded message from its canonical representation, the mail system incorrectly parses 21* the Delivery-By field using the sender's system as the default system for the Delivery-By address. The local 22* system should always be used as the default for the Delivery-By field 23* #0436 -- if a forum meeting is not found in the "forum" search list, the mail system will treat it as a version 1 24* forum in the working directory 25* #0437 -- if a message contains an empty multi-line field (eg: Redistributed-Comment), the parser will either take a 26* fault or cause a fatal process error 27* #0438 -- the primitives which allow a user to replace the address list portions of a message 28* (eg: mail_system_$replace_from, mail_system_$replace_user_field) should not make the user's copy of the address 29* list read-only. Instead, they should copy the user's list to allow the user to continue to modify the list if 30* desired for later additional use 31* 2) change(87-04-09,Lippard), approve(86-11-24,MCR7576), 32* audit(87-04-21,Dickson), install(87-04-26,MR12.1-1026): 33* Modified to use time_names.incl.pl1 instead of time_zones_.incl.pl1. 34* 3) change(88-05-16,Blair), approve(88-05-16,MCR7842), 35* audit(88-06-30,Lippard), install(88-07-26,MR12.2-1069): 36* Update parse_address to use the new search path mechanism so that 37* unexpanded mailbox pathnames of the form {keyword PATH} can be located. 38* END HISTORY COMMENTS */ 39 40 41 /* format: off */ 42 43 /* Mail System Utilities which convert the printed representation of various mail system objects (messages, addresses, 44* etc.) into their internal form */ 45 46 /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */ 47 48 49 mlsys_parse_text_: 50 procedure (); 51 52 return; /* not an entrypoint */ 53 54 55 /* Common Parameters */ 56 57 dcl P_code fixed binary (35) parameter; 58 59 dcl P_representation character (*) parameter; /* the text to be parsed */ 60 dcl P_parse_text_options_ptr pointer parameter; /* -> user's parsing options */ 61 dcl P_parse_text_error_list_ptr pointer parameter; /* set -> list of errors detected during parse */ 62 63 64 /* parse_im_message_text and parse_new_message_text Parameters */ 65 66 dcl P_message_version character (8) parameter; /* version of message structure desired by caller */ 67 dcl P_message_ptr pointer parameter; /* set -> the message */ 68 69 70 /* parse_im_message_text Parameters */ 71 72 dcl P_im_message_info_ptr pointer parameter; /* -> im_message_info describing the in-mailbox message */ 73 dcl P_last_delivered_by pointer; /* -> address of user ring-1 claims delivered the message */ 74 dcl P_last_date_time_delivered fixed binary (71) parameter;/* date/time when ring-1 delivered the message */ 75 dcl P_requests_acknowledgement bit (1) aligned parameter; /* ON => the message expects an acknowledgement */ 76 dcl P_multics_format bit (1) aligned parameter; /* ON => message is in standard Multics format */ 77 78 79 /* parse_mailing_list_text and parse_address_list_text Parameters */ 80 81 dcl P_address_list_version character (8) parameter; /* version of address_list structure desired by caller */ 82 dcl P_address_list_ptr pointer parameter; /* set -> the address_list */ 83 84 85 /* parse_address_text Parameters */ 86 87 dcl P_address_ptr pointer parameter; /* set -> the address */ 88 89 90 /* Local copies of parameters */ 91 92 dcl code fixed binary (35); 93 94 dcl representation character (representation_lth) unaligned based (representation_ptr); 95 dcl representation_ptr pointer; 96 dcl (representation_lth, representation_used) fixed binary (21); 97 98 dcl 1 local_pto aligned like parse_text_options; 99 100 dcl address_ptr pointer; 101 102 103 /* Remaining declarations */ 104 105 dcl new_message bit (1) aligned; /* ON => creating a new message; OFF => in-mailbox/incoming */ 106 dcl message_parse_fails bit (1) aligned; 107 108 dcl 1 message_type_specific_operations aligned, /* in-mailbox/new/incoming messages use different entries */ 109 2 add_address entry (pointer, pointer, character (8), fixed binary (35)) variable, 110 2 add_body_section entry (pointer, pointer, fixed binary, fixed binary (35)) variable, 111 2 add_redistribution entry (pointer, pointer, fixed binary, fixed binary (35)) variable, 112 2 add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35)) variable, 113 2 add_user_field entry (pointer, pointer, fixed binary, bit (1) aligned, fixed binary (35)) variable, 114 2 create_address_list entry (character (8), pointer, fixed binary (35)) variable, 115 2 delete_address entry (pointer, fixed binary, fixed binary (35)) variable, 116 2 encode_foreign_id entry (character (*), character (256) varying, bit (72) aligned) variable, 117 2 encode_local_id entry (fixed binary (71), bit (72) aligned) variable, 118 2 encode_psuedo_id entry (fixed binary (71), pointer, character (256) varying, bit (72) aligned) variable, 119 2 free_address_list entry (pointer, fixed binary (35)) variable, 120 2 free_message entry (pointer, fixed binary (35)) variable, 121 2 replace_bcc entry (pointer, pointer, fixed binary (35)) variable, 122 2 replace_cc entry (pointer, pointer, fixed binary (35)) variable, 123 2 replace_from entry (pointer, pointer, fixed binary (35)) variable, 124 2 replace_message_envelope entry (pointer, pointer, fixed binary (35)) variable, 125 2 replace_reply_to entry (pointer, pointer, fixed binary (35)) variable, 126 2 replace_subject entry (pointer, character (*), fixed binary (35)) variable, 127 2 replace_to entry (pointer, pointer, fixed binary (35)) variable, 128 2 set_address_implicit_route entry (pointer, pointer, fixed binary (35)) variable, 129 2 set_date_time_created entry (pointer, fixed binary (71), fixed binary (35)) variable, 130 2 set_message_id entry (pointer, bit (72) aligned, fixed binary (35)) variable; 131 132 dcl 1 internal_parse_options aligned, 133 2 default_system_name character (256) varying, /* system name for addresses without explicit name/route */ 134 2 last_delivered_by pointer, /* -> address of process that actually delivered message */ 135 2 last_date_time_delivered fixed binary (71), /* date/time it was delivered */ 136 2 flags, 137 3 default_system_is_local bit (1) unaligned, /* ON => the default system is this system */ 138 3 multics_format bit (1) unaligned, /* ON => use standard Multics formatting */ 139 3 no_copy bit (1) unaligned, /* ON => do not copy text where possible */ 140 3 requests_acknowledgement bit (1) unaligned, /* ON => put an Acknowledge-To field into last mailing */ 141 3 pad bit (14) unaligned, 142 2 delimiters, /* valid delimiters for this parse ... */ 143 3 eos bit (1) unaligned, /* ... end of the string */ 144 3 comma bit (1) unaligned, /* ... comma */ 145 3 angle_bracket bit (1) unaligned, /* ... angle bracket (>) */ 146 3 semicolon bit (1) unaligned, /* ... semi-colon */ 147 3 pad bit (14) unaligned; 148 149 dcl 1 mrps (forwarding_info_list.n_forwarding_infos) aligned based (mrps_ptr) like message_redistribution_parameter; 150 dcl 1 the_mrp aligned based (the_mrp_ptr) like message_redistribution_parameter; 151 dcl (mrps_ptr, the_mrp_ptr) pointer; 152 153 dcl mr_sort (forwarding_info_list.n_forwarding_infos) fixed binary based (mr_sort_ptr); 154 dcl mr_sort_ptr pointer; 155 156 dcl 1 local_mep aligned like message_envelope_parameter; 157 dcl 1 local_mrp aligned like message_reference_parameter; 158 dcl 1 local_mufp aligned like message_user_field_parameter; 159 dcl 1 local_mbsp aligned like message_body_section_parameter; 160 161 dcl 1 local_mtf aligned like message_text_field; 162 163 dcl system_area area aligned based (system_area_ptr); 164 dcl system_area_ptr pointer; 165 166 dcl user_area area aligned based (user_area_ptr); 167 dcl user_area_ptr pointer; 168 169 dcl forum_search_list_ptr pointer; 170 171 dcl (stack_extension_ptr, stack_truncation_ptr) pointer; 172 dcl stack_extension_used fixed binary (18); 173 174 dcl full_fieldname character (256) varying; 175 dcl (address_list_field, trace_address, comment_sender, redistribution_sender, acknowledge_to, implicit_route) pointer; 176 177 dcl (date_time_created, comment_date_time_created, date_time_last_relayed) fixed binary (71); 178 dcl message_id bit (72) aligned; 179 180 dcl (eol_idx, next_eol_idx, amount_good, line_start, line_end, used) fixed binary (21); 181 dcl (current_field_list_idx, first_field_idx) fixed binary; 182 dcl (n_sorted, sort_idx, idx, position) fixed binary; 183 184 dcl STACK_EXTENSION fixed binary (18) static options (constant) initial (1024); 185 186 dcl HTSP_COMMA character (3) static options (constant) initial (" ,"); 187 188 dcl LINE_DELIMITERS character (4) static options (constant) initial (" 189 "); 190 191 /* format: off */ 192 dcl MULTIPLE_FIELDS_PER_REDISTRIBUTION (18) bit (1) aligned static options (constant) initial ( 193 "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, 194 "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b); 195 196 dcl MULTIPLE_FIELDS_PER_COMMENT (18) bit (1) aligned static options (constant) initial ( 197 "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, 198 "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b); 199 200 dcl (UPPERCASE initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"), 201 LOWERCASE initial ("abcdefghijklmnopqrstuvwxyz")) 202 character (26) static options (constant); 203 204 dcl (error_table_$bad_subr_arg, error_table_$entlong, error_table_$nostars, error_table_$smallarg, 205 error_table_$unimplemented_version, mlsys_et_$address_pathname_expected, mlsys_et_$cant_determine_dtc, 206 mlsys_et_$cant_determine_msgid, mlsys_et_$cant_determine_sender, mlsys_et_$cant_parse_irt_field, 207 mlsys_et_$comment_ignored, mlsys_et_$empty_address_text, mlsys_et_$extra_restricted_field, 208 mlsys_et_$in_mailbox_only_field, mlsys_et_$incomplete_address_list_text, mlsys_et_$incomplete_address_text, 209 mlsys_et_$incomplete_comment, mlsys_et_$incomplete_named_group_text, mlsys_et_$invalid_address_list_syntax, 210 mlsys_et_$invalid_address_syntax, mlsys_et_$invalid_named_group_text, mlsys_et_$invalid_relayed_field_syntax, 211 mlsys_et_$invalid_route_field_syntax, mlsys_et_$missing_host_name, mlsys_et_$multiple_address_routes, 212 mlsys_et_$no_comment_redistribution, mlsys_et_$no_message_header, mlsys_et_$obsolete_address_syntax, 213 mlsys_et_$only_address_route_allowed, mlsys_et_$recursive_named_addresses, mlsys_et_$text_follows_address, 214 mlsys_et_$text_follows_route, mlsys_et_$text_parse_failed, mlsys_et_$unbalanced_braces, 215 mlsys_et_$unbalanced_parentheses, mlsys_et_$unbalanced_quotes, mlsys_et_$unknown_structured_address_type) 216 fixed binary (35) external; 217 /* format: on */ 218 219 dcl check_star_name_$entry entry (character (*), fixed binary (35)); 220 dcl convert_date_to_binary_ entry (character (*), fixed binary (71), fixed binary (35)); 221 dcl cu_$grow_stack_frame entry (fixed binary (18), pointer, fixed binary (35)); 222 dcl cu_$shrink_stack_frame entry (pointer, fixed binary (35)); 223 dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); 224 dcl encode_clock_value_ 225 entry (fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary, fixed binary (71), 226 fixed binary, character (3), fixed binary (71), fixed binary (35)); 227 dcl expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35)); 228 dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); 229 dcl expand_pathname_$component_add_suffix 230 entry (character (*), character (*), character (*), character (*), character (*), fixed binary (35)); 231 dcl forum_$get_forum_path entry (character (*), character (*), character (*), character (*), fixed binary (35)); 232 dcl get_system_free_area_ entry () returns (pointer); 233 dcl mail_system_$add_address entry (pointer, pointer, character (8), fixed binary (35)); 234 dcl mail_system_$add_body_section entry (pointer, pointer, fixed binary, fixed binary (35)); 235 dcl mail_system_$add_user_field entry (pointer, pointer, fixed binary, bit (1) aligned, fixed binary (35)); 236 dcl mail_system_$compare_addresses entry (pointer, pointer, fixed binary (35)) returns (bit (1) aligned); 237 dcl mail_system_$create_address_list entry (character (8), pointer, fixed binary (35)); 238 dcl mail_system_$create_foreign_address 239 entry (character (*) varying, character (256) varying, pointer, character (*) varying, character (*) varying, 240 pointer, fixed binary (35)); 241 dcl mail_system_$create_forum_address 242 entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35)); 243 dcl mail_system_$create_invalid_address 244 entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35)); 245 dcl mail_system_$create_logbox_address 246 entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35)); 247 dcl mail_system_$create_mail_table_address 248 entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35)); 249 dcl mail_system_$create_mailbox_address 250 entry (character (*), character (*), character (*) varying, character (*) varying, pointer, fixed binary (35)); 251 dcl mail_system_$create_mailing_list_address 252 entry (character (*), character (*), character (*), character (*) varying, character (*) varying, pointer, 253 fixed binary (35)); 254 dcl mail_system_$create_message entry (character (8), pointer, fixed binary (35)); 255 dcl mail_system_$create_named_group_address 256 entry (character (*) varying, pointer, bit (1) aligned, character (*) varying, pointer, fixed binary (35)); 257 dcl mail_system_$create_savebox_address 258 entry (character (*) varying, character (*), character (*), character (*) varying, character (*) varying, 259 pointer, fixed binary (35)); 260 dcl mail_system_$create_user_mailbox_address 261 entry (character (*) varying, character (*) varying, character (*) varying, pointer, fixed binary (35)); 262 dcl mail_system_$delete_address entry (pointer, fixed binary, fixed binary (35)); 263 dcl mail_system_$free_address entry (pointer, fixed binary (35)); 264 dcl mail_system_$free_address_list entry (pointer, fixed binary (35)); 265 dcl mail_system_$free_message entry (pointer, fixed binary (35)); 266 dcl mail_system_$get_address_route entry (pointer, character (8), pointer, fixed binary (35)); 267 dcl mail_system_$get_address_system entry (pointer, character (256) varying, fixed binary (35)); 268 dcl mail_system_$get_address_type entry (pointer, fixed binary, fixed binary (35)); 269 dcl mail_system_$get_user_field_id entry (character (*), bit (36) aligned, character (*) varying, fixed binary (35)); 270 dcl mail_system_$get_user_field_name entry (bit (36) aligned, character (*) varying, fixed binary (35)); 271 dcl mail_system_$replace_bcc entry (pointer, pointer, fixed binary (35)); 272 dcl mail_system_$replace_cc entry (pointer, pointer, fixed binary (35)); 273 dcl mail_system_$replace_from entry (pointer, pointer, fixed binary (35)); 274 dcl mail_system_$replace_reply_to entry (pointer, pointer, fixed binary (35)); 275 dcl mail_system_$replace_subject entry (pointer, character (*), fixed binary (35)); 276 dcl mail_system_$replace_to entry (pointer, pointer, fixed binary (35)); 277 dcl mail_system_$validate_address entry (pointer, bit (1) aligned, fixed binary (35)); 278 dcl mlsys_address_list_mgr_$add_address entry (pointer, pointer, character (8), fixed binary (35)); 279 dcl mlsys_address_list_mgr_$create_read_only_address_list entry (character (8), pointer, fixed binary (35)); 280 dcl mlsys_address_list_mgr_$create_user_freeable_address_list entry (character (8), pointer, fixed binary (35)); 281 dcl mlsys_address_list_mgr_$delete_address entry (pointer, fixed binary, fixed binary (35)); 282 dcl mlsys_address_list_mgr_$free_address_list entry (pointer, fixed binary (35)); 283 dcl mlsys_address_mgr_$set_address_implicit_route entry (pointer, pointer, fixed binary (35)); 284 dcl mlsys_field_id_mgr_$get_system_field_type entry (character (*), fixed binary, fixed binary (35)); 285 dcl mlsys_message_id_mgr_$encode_foreign_id entry (character (*), character (256) varying, bit (72) aligned); 286 dcl mlsys_message_id_mgr_$encode_local_id entry (fixed binary (71), bit (72) aligned); 287 dcl mlsys_message_id_mgr_$encode_psuedo_id entry (fixed binary (71), pointer, character (256) varying, bit (72) aligned); 288 dcl mlsys_message_mgr_$add_body_section_no_copy entry (pointer, pointer, fixed binary, fixed binary (35)); 289 dcl mlsys_message_mgr_$add_redistribution_no_copy entry (pointer, pointer, fixed binary, fixed binary (35)); 290 dcl mlsys_message_mgr_$add_reply_reference entry (pointer, pointer, fixed binary, fixed binary (35)); 291 dcl mlsys_message_mgr_$add_user_field_no_copy entry (pointer, pointer, fixed binary, bit (1) aligned, fixed binary (35)); 292 dcl mlsys_message_mgr_$create_im_message entry (character (8), pointer, pointer, fixed binary (35)); 293 dcl mlsys_message_mgr_$free_message entry (pointer, fixed binary (35)); 294 dcl mlsys_message_mgr_$replace_bcc_no_copy entry (pointer, pointer, fixed binary (35)); 295 dcl mlsys_message_mgr_$replace_cc_no_copy entry (pointer, pointer, fixed binary (35)); 296 dcl mlsys_message_mgr_$replace_from_no_copy entry (pointer, pointer, fixed binary (35)); 297 dcl mlsys_message_mgr_$replace_message_envelope entry (pointer, pointer, fixed binary (35)); 298 dcl mlsys_message_mgr_$replace_reply_to_no_copy entry (pointer, pointer, fixed binary (35)); 299 dcl mlsys_message_mgr_$replace_subject_no_copy entry (pointer, character (*), fixed binary (35)); 300 dcl mlsys_message_mgr_$replace_to_no_copy entry (pointer, pointer, fixed binary (35)); 301 dcl mlsys_nit_interface_$get_local_system_name entry () returns (character (256) varying); 302 dcl mlsys_nit_interface_$is_local_system entry (character (256) varying) returns (bit (1) aligned); 303 dcl mlsys_psp_$forum_not_available entry () returns (bit (1) aligned); 304 dcl mlsys_user_mte_syntax_$classify_and_validate 305 entry (character (*) varying, bit (1) aligned, character (*) varying, character (*) varying, fixed binary (35)); 306 dcl search_paths_$get 307 entry (character (*), bit (36), character (*), pointer, pointer, fixed binary, pointer, fixed binary (35)); 308 309 dcl cleanup condition; 310 311 dcl (abs, addr, addcharno, addwordno, baseno, before, charno, hbound, index, lbound, length, max, min, mod, null, 312 reverse, rtrim, search, size, stackframeptr, string, substr, translate, verify) builtin; 313 314 /* Results of scanning the text of a message for header fields */ 315 316 dcl 1 message_scan aligned, 317 2 header_offset fixed binary (21), /* offset of header in message ignoring leading NLs */ 318 2 body, /* the message body */ 319 3 body_ptr pointer, 320 3 body_lth fixed binary (21), 321 2 n_header_fields_allocated fixed binary, /* size of several arrays below */ 322 2 array_pointers, /* makes setup simpler */ 323 3 header_field_list_ptr pointer, /* -> the list defining the actual header fields */ 324 3 field_by_type_lists_ptr pointer, /* -> the list breaking the fields down by type */ 325 3 forwarding_info_list_ptr pointer, /* -> the list of forwarding fields */ 326 3 comment_info_list_ptr pointer, /* -> the list of comment fields */ 327 3 user_field_list_ptr pointer; /* -> the list of user-defined fields */ 328 329 330 dcl 1 header_field_list aligned based (message_scan.header_field_list_ptr), 331 2 n_fields fixed binary, /* # of fields actually found */ 332 2 fields (message_scan.n_header_fields_allocated), /* the actual fields */ 333 3 field_value_ptr pointer, /* -> start of textual content of the field */ 334 3 field_value_lth fixed binary (21), /* length of the field in characters */ 335 3 complete_field_start fixed binary (21), /* offset/length of the entire field (including header) ... */ 336 3 complete_field_lth fixed binary (21); /* ... for use in error reporting */ 337 338 dcl header_field_value character (header_field_list.fields (field_idx).field_value_lth) unaligned 339 based (header_field_list.fields (field_idx).field_value_ptr); 340 dcl field_idx fixed binary; /* index of field whose value is above declaration */ 341 342 343 dcl 1 field_by_type_lists aligned based (message_scan.field_by_type_lists_ptr), 344 2 types (N_ORDINARY_FIELDS), /* one array element for each type */ 345 3 n_fields fixed binary, /* # of fields of this type found */ 346 3 field_idxs (message_scan.n_header_fields_allocated) fixed binary; 347 /* index into header_field_list.fields of each field found */ 348 349 350 dcl 1 forwarding_info_list aligned based (message_scan.forwarding_info_list_ptr), 351 2 n_forwarding_infos fixed binary, /* # of separate forwarding infos actually found */ 352 2 forwarding_info_ptrs (message_scan.n_header_fields_allocated) pointer; 353 /* -> field_by_type_lists for each forwarding */ 354 355 dcl 1 forwarding_info aligned based (forwarding_info_ptr) like field_by_type_lists; 356 dcl forwarding_info_ptr pointer; 357 358 359 dcl 1 comment_info_list aligned based (message_scan.comment_info_list_ptr), 360 2 n_comment_infos fixed binary, /* # of separate comment infos actually found */ 361 2 comment_info_ptrs (message_scan.n_header_fields_allocated) pointer; 362 /* -> field_by_type_lists for each comment */ 363 364 dcl 1 comment_info aligned based (comment_info_ptr) like field_by_type_lists; 365 dcl comment_info_ptr pointer; 366 367 dcl 1 user_field_list aligned based (message_scan.user_field_list_ptr), 368 2 n_user_fields fixed binary, /* # of user fields found */ 369 2 user_fields (message_scan.n_header_fields_allocated), 370 3 field_id bit (36) aligned, /* ID assigned to group all similar user fields */ 371 3 field_value_idx fixed binary; /* index into header_field_list of this field */ 372 373 /* Declarations used to convert the input text into a series of tokens */ 374 375 dcl original_text character (original_text_lth) unaligned based (original_text_ptr); 376 dcl original_text_lth fixed binary (21); 377 dcl original_text_ptr pointer; 378 379 dcl 1 lex_and_parse_pointers aligned, /* allows easy setting of all these pointers */ 380 2 all_but_sel_ptr, 381 3 token_list_ptr pointer, 382 3 unquoted_text_ptr pointer, 383 3 host_indeces_ptr pointer, 384 3 address_string_ptr pointer, 385 3 address_name_ptr pointer, 386 3 address_comment_ptr pointer, 387 2 sel_ptr pointer; 388 389 dcl unquoted_text character (original_text_lth) unaligned based (lex_and_parse_pointers.unquoted_text_ptr); 390 /* used by lex when processing quoted strings */ 391 392 dcl 1 token aligned based (token_ptr), /* a single token from the string */ 393 2 token_ptr pointer, /* -> the text */ 394 2 token_lth fixed binary (21), /* length of text in characters */ 395 2 original_start fixed binary (21), /* index in caller's text of start of token */ 396 2 original_lth fixed binary (21), /* length of the original (maybe quoted) version of token */ 397 2 type fixed binary, /* type of token (see below) */ 398 2 flags, 399 3 in_unquoted bit (1) unaligned, /* ON => text was reconstructed (quoted or something) */ 400 3 pad bit (35) unaligned; 401 dcl token_ptr pointer; 402 403 dcl 1 current aligned like token based (current_token_ptr);/* the token under examination */ 404 dcl current_token_ptr pointer; 405 dcl token_idx fixed binary (21); /* index of current token in the token list */ 406 407 dcl current_token character (current.token_lth) unaligned based (current.token_ptr); 408 /* the actual text of the token */ 409 410 dcl 1 token_list aligned based (lex_and_parse_pointers.token_list_ptr), 411 2 n_tokens_allocated fixed binary (21), /* # of tokens below */ 412 2 n_tokens_used fixed binary (21), /* # of tokens in use */ 413 2 tokens (0:(original_text_lth + 1) refer (token_list.n_tokens_allocated)) like token; 414 415 /* format: off */ 416 417 /* Token types common to all forms of lexical analysis */ 418 419 dcl (START_OF_TEXT_TOKEN initial (-3), /* start of text: always the first token in the list */ 420 END_OF_TEXT_TOKEN initial (-2), /* end of the text: always the last token in the list */ 421 WORD_TOKEN initial (-1), /* a piece of text (it might have been quoted) */ 422 COMMENT_TOKEN initial (0), /* the text of a comment */ 423 424 COMMA_TOKEN initial (1), /* comma and colon delimiters are common to both lex's */ 425 COLON_TOKEN initial (2), 426 427 428 /* Token types for parsing address, address-list, and message-id fields */ 429 430 SEMICOLON_TOKEN initial (3), LEFTBRACE_TOKEN initial (4), 431 RIGHTBRACE_TOKEN initial (5), LEFTBRACKET_TOKEN initial (6), 432 RIGHTBRACKET_TOKEN initial (7), AT_TOKEN initial (8), 433 434 435 /* Token types for parsing date/time fields */ 436 437 PLUS_TOKEN initial (3), HYPHEN_TOKEN initial (4)) 438 fixed binary static options (constant); 439 /* format: on */ 440 441 442 /* Declarations used for parsing addresses and address lists */ 443 444 dcl 1 sel (original_text_lth) aligned based (lex_and_parse_pointers.sel_ptr), 445 2 text_start fixed binary (21), /* index in original text of substring in error */ 446 2 text_lth fixed binary (21), /* ... and the length of said substring */ 447 2 code fixed binary (35); /* error code describing problem */ 448 dcl n_syntax_errors fixed binary (21); /* # of errors detected by the parse */ 449 450 dcl host_indeces (original_text_lth) fixed binary (21) based (lex_and_parse_pointers.host_indeces_ptr); 451 dcl n_hosts fixed binary; /* # of host names in the address */ 452 dcl n_reversed_hosts fixed binary; /* # of host names in RFC822 style route */ 453 454 dcl address_string character (original_text_lth + 1) varying based (lex_and_parse_pointers.address_string_ptr); 455 dcl address_name character (original_text_lth + 1) varying based (lex_and_parse_pointers.address_name_ptr); 456 dcl address_comment character (original_text_lth + 1) varying based (lex_and_parse_pointers.address_comment_ptr); 457 458 459 /* Declarations used for parsing date/times */ 460 461 dcl ONE_MINUTE fixed binary (71) static options (constant) initial (60000000); 462 463 /* format: off */ 464 dcl DAY_OF_WEEKS (14) character (32) static options (constant) initial ( 465 "SUNDAY", "SUN", "MONDAY", "MON", "TUESDAY", "TUE", "WEDNESDAY", "WED", 466 "THURSDAY", "THU", "FRIDAY", "FRI", "SATURDAY", "SAT"); 467 dcl DAY_OF_WEEK_VALUES (14) fixed binary static options (constant) initial ( 468 (2) 7, (2) 1, (2) 2, (2) 3, 469 (2) 4, (2) 5, (2) 6); 470 471 dcl MONTHS (23) character (32) static options (constant) initial ( 472 "JANUARY", "JAN", "FEBRUARY", "FEB", "MARCH", "MAR", "APRIL", "APR", 473 "MAY", "JUNE", "JUN", "JULY", "JUL", "AUGUST", "AUG", 474 "SEPTEMBER", "SEP", "OCTOBER", "OCT", "NOVEMBER", "NOV", "DECEMBER", "DEC"); 475 dcl MONTH_VALUES (23) fixed binary static options (constant) initial ( 476 (2) 1, (2) 2, (2) 3, (2) 4, 477 5, (2) 6, (2) 7, (2) 8, 478 (2) 9, (2) 10, (2) 11, (2) 12); 479 480 dcl RFC822_ZONES (35) character (4) static options (constant) initial ( 481 "GMT", "UT", "EST", "EDT", "CST", "CDT", "MST", "MDT", "PST", "PDT", 482 "Z", "A", "B", "C", "D", "E", "F", "G", "H", "I", 483 "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", 484 "U", "V", "W", "X", "Y"); 485 dcl RFC822_ZONE_OFFSETS (35) fixed binary static options (constant) initial ( 486 0, 0, -300, -240, -360, -300, -420, -360, -480, -420, 487 0, -60, -120, -180, -240, -300, -360, -420, -480, -540, 488 -600, -660, -720, 60, 120, 180, 240, 300, 360, 420, 489 480, 540, 600, 660, 720); 490 /* format: on */ 491 492 /* Convert the printed representation of an in-mailbox message into its internal representation */ 493 494 parse_im_message_text: 495 entry (P_representation, P_message_version, P_im_message_info_ptr, P_last_delivered_by, P_last_date_time_delivered, 496 P_requests_acknowledgement, P_multics_format, P_message_ptr, P_code); 497 498 new_message = "0"b; /* building an in-mailbox message */ 499 500 local_pto.version = PARSE_TEXT_OPTIONS_VERSION_1; /* setup common parse options */ 501 local_pto.area_ptr = null (); 502 string (local_pto.flags) = ""b; /* ... don't list errors or validate addresses */ 503 local_pto.include_invalid_addresses = "1"b; /* ... but include everything possible in the message */ 504 parse_text_options_ptr = addr (local_pto); 505 506 string (internal_parse_options.flags) = ""b; /* ... will determine the default system later */ 507 internal_parse_options.multics_format = P_multics_format; 508 /* ... use new-style formatting if necessary */ 509 internal_parse_options.no_copy = "1"b; /* ... use the actual message text when possible */ 510 511 internal_parse_options.last_delivered_by = P_last_delivered_by; 512 internal_parse_options.last_date_time_delivered = P_last_date_time_delivered; 513 internal_parse_options.requests_acknowledgement = P_requests_acknowledgement; 514 515 add_address = mlsys_address_list_mgr_$add_address; 516 add_body_section = mlsys_message_mgr_$add_body_section_no_copy; 517 add_redistribution = mlsys_message_mgr_$add_redistribution_no_copy; 518 add_reply_reference = mlsys_message_mgr_$add_reply_reference; 519 add_user_field = mlsys_message_mgr_$add_user_field_no_copy; 520 create_address_list = mlsys_address_list_mgr_$create_read_only_address_list; 521 delete_address = mlsys_address_list_mgr_$delete_address; 522 encode_foreign_id = mlsys_message_id_mgr_$encode_foreign_id; 523 encode_local_id = mlsys_message_id_mgr_$encode_local_id; 524 encode_psuedo_id = mlsys_message_id_mgr_$encode_psuedo_id; 525 free_address_list = mlsys_address_list_mgr_$free_address_list; 526 free_message = mlsys_message_mgr_$free_message; 527 replace_bcc = mlsys_message_mgr_$replace_bcc_no_copy; 528 replace_cc = mlsys_message_mgr_$replace_cc_no_copy; 529 replace_from = mlsys_message_mgr_$replace_from_no_copy; 530 replace_message_envelope = mlsys_message_mgr_$replace_message_envelope; 531 replace_reply_to = mlsys_message_mgr_$replace_reply_to_no_copy; 532 replace_subject = mlsys_message_mgr_$replace_subject_no_copy; 533 replace_to = mlsys_message_mgr_$replace_to_no_copy; 534 set_address_implicit_route = mlsys_address_mgr_$set_address_implicit_route; 535 set_date_time_created = set_date_time_created_directly; 536 set_message_id = set_message_id_directly; 537 538 call mlsys_message_mgr_$create_im_message (P_message_version, P_im_message_info_ptr, message_ptr, code); 539 if code ^= 0 then do; /* wrong version? */ 540 P_code = code; 541 return; 542 end; 543 544 go to PARSE_MESSAGE_TEXT_COMMON; 545 546 /* Convert the printed representation of a new message into its internal representation */ 547 548 parse_new_message_text: 549 entry (P_representation, P_parse_text_options_ptr, P_message_version, P_message_ptr, P_parse_text_error_list_ptr, 550 P_code); 551 552 new_message = "1"b; /* building a new message */ 553 554 parse_text_options_ptr = P_parse_text_options_ptr; 555 if parse_text_options.version ^= PARSE_TEXT_OPTIONS_VERSION_1 then do; 556 P_code = error_table_$unimplemented_version; 557 return; 558 end; 559 if parse_text_options.mbz ^= ""b then do; 560 P_code = error_table_$bad_subr_arg; 561 return; 562 end; 563 564 if parse_text_options.area_ptr = null () then 565 user_area_ptr = get_system_free_area_ (); 566 else user_area_ptr = parse_text_options.area_ptr; 567 568 string (internal_parse_options.flags) = ""b; 569 internal_parse_options.multics_format = "1"b; /* use standard Multics formatting conventions */ 570 internal_parse_options.no_copy = "0"b; /* can't use supplied text directly */ 571 572 internal_parse_options.default_system_is_local = "1"b; 573 internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name (); 574 575 internal_parse_options.last_delivered_by = null (); 576 internal_parse_options.last_date_time_delivered = 0; 577 internal_parse_options.requests_acknowledgement = "0"b; 578 /* message has never been sent anywhere */ 579 580 add_address = mail_system_$add_address; 581 add_body_section = mail_system_$add_body_section; 582 add_user_field = mail_system_$add_user_field; 583 create_address_list = mail_system_$create_address_list; 584 delete_address = mail_system_$delete_address; 585 free_address_list = mail_system_$free_address_list; 586 free_message = mail_system_$free_message; 587 replace_bcc = mail_system_$replace_bcc; 588 replace_cc = mail_system_$replace_cc; 589 replace_from = mail_system_$replace_from; 590 replace_reply_to = mail_system_$replace_reply_to; 591 replace_subject = mail_system_$replace_subject; 592 replace_to = mail_system_$replace_to; 593 594 call mail_system_$create_message (P_message_version, message_ptr, code); 595 if code ^= 0 then do; /* wrong version? */ 596 P_code = code; 597 return; 598 end; 599 600 go to PARSE_MESSAGE_TEXT_COMMON; 601 602 /* The Message Parser */ 603 604 PARSE_MESSAGE_TEXT_COMMON: 605 representation_ptr = addr (P_representation); 606 representation_lth = length (P_representation); 607 608 string (internal_parse_options.delimiters) = ""b; /* end of string is only address/address list delimiter */ 609 internal_parse_options.delimiters.eos = "1"b; 610 611 message_parse_fails = "0"b; /* assume no errors are detected */ 612 613 system_area_ptr = get_system_free_area_ (); 614 615 call initialize_message_parse_data (); /* for cleanup handler */ 616 617 on condition (cleanup) 618 begin; 619 call cleanup_message_parse_data (); 620 if message_ptr ^= null () then call free_message (message_ptr, (0)); 621 end; 622 623 624 /* Find and classify all header fields */ 625 626 call scan_message_text (parse_text_options, internal_parse_options); 627 628 629 /* Add the body to the message: whatever body is present is treated as a single, preformatted section */ 630 631 local_mbsp.version = MESSAGE_BODY_SECTION_PARAMETER_VERSION_2; 632 633 message_body_section_ptr = addr (local_mbsp.section); 634 message_preformatted_body_section.section_type = MESSAGE_PREFORMATTED_BODY_SECTION; 635 message_preformatted_body_section.text_ptr = message_scan.body_ptr; 636 message_preformatted_body_section.text_lth = message_scan.body_lth; 637 638 call add_body_section (message_ptr, addr (local_mbsp), (-1), code); 639 if code ^= 0 then call message_parse_error_fatal (code); 640 641 642 if new_message then do; 643 644 /* New Message -- Parse the From field and mark all "restricted" header fields and all field in the envelope as errors */ 645 646 call parse_address_list_field (parse_text_options, internal_parse_options, FROM_FIELDNAME, 647 addr (field_by_type_lists.types (FROM_FIELD)), address_list_field); 648 if address_list_field ^= null () then do; /* ... there's something in the From field */ 649 call replace_from (message_ptr, address_list_field, code); 650 if code ^= 0 then call message_parse_error_fatal (code); 651 if address_list_field = message.from then 652 address_list_field = null (); 653 else call free_address_list (address_list_field, (0)); 654 end; 655 656 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (ACCESS_CLASS_FIELD))); 657 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (ACKNOWLEDGE_TO_FIELD))); 658 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (DATE_FIELD))); 659 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (DELIVERY_BY_FIELD))); 660 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (DELIVERY_DATE_FIELD))); 661 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (MESSAGE_ID_FIELD))); 662 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (POSTED_DATE_FIELD))); 663 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (RELAYED_FIELD))); 664 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (ROUTE_FIELD))); 665 call mark_as_in_mailbox_field (addr (field_by_type_lists.types (SENDER_FIELD))); 666 end; 667 668 else do; 669 670 /* In-mailbox/Incoming Message -- Parse the message envelope: However, the envelope is not added to the message at this 671* time as it is possible that either the message trace or Acknowledge-To field or both which appear to be part of the 672* envelope are actually part of one of the message redistributions. As part of parsing the envelope, we also parse the 673* Date and From fields in the header as we may need their values to complete the envelope parse; we may also need their 674* values to construct a unique ID for the message if there's no Message-ID field */ 675 676 first_field_idx = 1; /* message starts at the beginning ... */ 677 678 local_mep.version = MESSAGE_ENVELOPE_PARAMETER_VERSION_2; 679 680 call parse_envelope (parse_text_options, internal_parse_options, "0"b, 681 message_scan.field_by_type_lists_ptr, addr (local_mep.envelope), date_time_created, 682 address_list_field); /* takes care of both Date and From fields also */ 683 684 call set_date_time_created (message_ptr, date_time_created, code); 685 if code ^= 0 then call message_parse_error_fatal (code); 686 687 if address_list_field ^= null () then do; /* ... there's something in the From field */ 688 call replace_from (message_ptr, address_list_field, code); 689 if code ^= 0 then call message_parse_error_fatal (code); 690 if address_list_field = message.from then 691 address_list_field = null (); 692 else call free_address_list (address_list_field, (0)); 693 end; 694 695 696 /* In-mailbox/Incoming Message -- Determine the unique ID of the message: If there is exactly one Message-ID field, 697* convert it into the ID; if there is no Message-ID field, construct a psuedo-ID from the Date and From fields; if there 698* is more than one Message-ID field, flag them all as errors */ 699 700 message_id = ""b; /* assume we don't get one */ 701 702 if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields = 1 then do; 703 field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (1); 704 call parse_message_id_text (parse_text_options, internal_parse_options, header_field_value, 705 message_id); /* text can always be converted to a message ID */ 706 end; 707 708 else if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields > 1 then do; 709 do idx = 1 to field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields; 710 field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (idx); 711 call message_parse_error (parse_text_options, mlsys_et_$extra_restricted_field, 712 header_field_list.fields (field_idx).complete_field_start, 713 header_field_list.fields (field_idx).complete_field_lth, ""); 714 end; 715 end; 716 717 else do; /* must construct a psudeo ID */ 718 if (message.date_time_created ^= 0) & (message.from -> address_list.n_addresses > 0) then 719 call encode_psuedo_id (message.date_time_created, message.from, 720 internal_parse_options.default_system_name, message_id); 721 else call message_parse_error (parse_text_options, mlsys_et_$cant_determine_msgid, 722 header_field_list.fields (1).complete_field_start, 723 header_field_list.fields (1).complete_field_lth, "The message which starts with:"); 724 end; 725 726 if message_id ^= ""b then do; /* found an ID ... */ 727 call set_message_id (message_ptr, message_id, code); 728 if code ^= 0 then call message_parse_error_fatal (code); 729 end; 730 end; 731 732 733 /* Parse the Reply-To, To, cc, and bcc fields */ 734 735 if field_by_type_lists.types (REPLY_TO_FIELD).n_fields > 0 then do; 736 call parse_address_list_field (parse_text_options, internal_parse_options, REPLY_TO_FIELDNAME, 737 addr (field_by_type_lists.types (REPLY_TO_FIELD)), address_list_field); 738 if address_list_field ^= null () then do; /* ... there's something in the Reply-To field */ 739 call replace_reply_to (message_ptr, address_list_field, code); 740 if code ^= 0 then call message_parse_error_fatal (code); 741 if address_list_field = message.reply_to then 742 address_list_field = null (); 743 else call free_address_list (address_list_field, (0)); 744 end; 745 end; 746 747 if field_by_type_lists.types (TO_FIELD).n_fields > 0 then do; 748 call parse_address_list_field (parse_text_options, internal_parse_options, TO_FIELDNAME, 749 addr (field_by_type_lists.types (TO_FIELD)), address_list_field); 750 if address_list_field ^= null () then do; /* ... there's something in the To field */ 751 call replace_to (message_ptr, address_list_field, code); 752 if code ^= 0 then call message_parse_error_fatal (code); 753 if address_list_field = message.to then 754 address_list_field = null (); 755 else call free_address_list (address_list_field, (0)); 756 end; 757 end; 758 759 if field_by_type_lists.types (CC_FIELD).n_fields > 0 then do; 760 call parse_address_list_field (parse_text_options, internal_parse_options, CC_FIELDNAME, 761 addr (field_by_type_lists.types (CC_FIELD)), address_list_field); 762 if address_list_field ^= null () then do; /* ... there's something in the cc field */ 763 call replace_cc (message_ptr, address_list_field, code); 764 if code ^= 0 then call message_parse_error_fatal (code); 765 if address_list_field = message.cc then 766 address_list_field = null (); 767 else call free_address_list (address_list_field, (0)); 768 end; 769 end; 770 771 if field_by_type_lists.types (BCC_FIELD).n_fields > 0 then do; 772 call parse_address_list_field (parse_text_options, internal_parse_options, BCC_FIELDNAME, 773 addr (field_by_type_lists.types (BCC_FIELD)), address_list_field); 774 if address_list_field ^= null () then do; /* ... there's something in the bcc field */ 775 call replace_bcc (message_ptr, address_list_field, code); 776 if code ^= 0 then call message_parse_error_fatal (code); 777 if address_list_field = message.bcc then 778 address_list_field = null (); 779 else call free_address_list (address_list_field, (0)); 780 end; 781 end; 782 783 784 /* Parse the Subject field: if there are several Subject fields in the message, merge them into a single field */ 785 786 if field_by_type_lists.types (SUBJECT_FIELD).n_fields > 0 then do; 787 call prepare_single_line_field (local_mtf, addr (field_by_type_lists.types (SUBJECT_FIELD))); 788 begin; 789 dcl message_subject character (local_mtf.text_lth) unaligned based (local_mtf.text_ptr); 790 call replace_subject (message_ptr, message_subject, code); 791 if field_by_type_lists.types (SUBJECT_FIELD).n_fields > 1 then 792 if message.subject.text_ptr ^= addr (message_subject) then free message_subject in (system_area); 793 if code ^= 0 then call message_parse_error_fatal (code); 794 end; 795 end; 796 797 798 if field_by_type_lists.types (IN_REPLY_TO_FIELD).n_fields > 0 then 799 if new_message then do; 800 801 /* New Message -- Mark all In-Reply-To fields as errors: Privileged operations are required to convert the printed 802* representation of a message reference into its internal form */ 803 804 do idx = 1 to field_by_type_lists.types (IN_REPLY_TO_FIELD).n_fields; 805 field_idx = field_by_type_lists.types (IN_REPLY_TO_FIELD).field_idxs (idx); 806 call message_parse_error (parse_text_options, mlsys_et_$cant_parse_irt_field, 807 header_field_list.fields (field_idx).complete_field_start, 808 header_field_list.fields (field_idx).complete_field_lth, ""); 809 end; 810 end; 811 812 else do; 813 814 /* In-mailbox/Incoming Message -- Parse the In-Reply-To fields: We can not actually parse the In-Reply-To field as the 815* format of the printed representation is not complete enough for parsing. Therefore, we take each separate line of the 816* In-Reply-To fields and treat it as a separate reference; a message ID is generated for each line based on its text so 817* that there will be something available to convert back into the printed form */ 818 819 local_mrp.version = MESSAGE_REFERENCE_PARAMETER_VERSION_2; 820 local_mrp.date_time_created = 0; /* there's never any date/time, authors, or subject */ 821 local_mrp.from, local_mrp.subject.text_ptr = null (); 822 local_mrp.subject.text_lth = 0; 823 824 do idx = 1 to field_by_type_lists.types (IN_REPLY_TO_FIELD).n_fields; 825 field_idx = field_by_type_lists.types (IN_REPLY_TO_FIELD).field_idxs (idx); 826 827 used = 0; 828 do while (used < length (header_field_value)); 829 begin; 830 dcl rest_of_field char (length (header_field_value) - used) unaligned defined (header_field_value) position (used + 1); 831 eol_idx = index (rest_of_field, NL); 832 if eol_idx = 0 then eol_idx = length (rest_of_field) + 1; 833 end; 834 begin; /* have the next line to convert ... */ 835 dcl next_line character (eol_idx - 1) unaligned defined (header_field_value) position (used + 1); 836 line_start = verify (next_line, HTSP_COMMA); 837 if line_start ^= 0 then do; 838 /* ... something on the line */ 839 line_end = length (rtrim (next_line, HTSP_COMMA)); 840 begin; 841 dcl the_line character (line_end - line_start + 1) unaligned defined (header_field_value) position (used + line_start); 842 call encode_foreign_id (the_line, 843 mlsys_nit_interface_$get_local_system_name (), local_mrp.message_id); 844 call add_reply_reference (message_ptr, addr (local_mrp), (-1), code); 845 if code ^= 0 then call message_parse_error_fatal (code); 846 end; 847 end; 848 end; 849 used = used + eol_idx; /* on to the next line */ 850 end; 851 end; 852 end; 853 854 855 /* Convert the user-defined fields: Until messages are stored in binary, we must assume that all user-defined fields are 856* text fields */ 857 858 local_mufp.version = MESSAGE_USER_FIELD_PARAMETER_VERSION_2; 859 message_user_field_ptr = addr (local_mufp.user_field); 860 message_user_field.field_type = MESSAGE_TEXT_USER_FIELD; 861 862 do idx = 1 to user_field_list.n_user_fields; 863 field_idx = user_field_list.user_fields (idx).field_value_idx; 864 message_user_field.field_id = user_field_list.user_fields (idx).field_id; 865 866 message_text_user_field.multiline_text = (search (header_field_value, LINE_DELIMITERS) ^= 0); 867 if message_text_user_field.multiline_text then do; 868 call mail_system_$get_user_field_name (message_text_user_field.field_id, full_fieldname, (0)); 869 message_text_user_field.text_ptr = null (); 870 message_text_user_field.text_lth = 0; 871 call prepare_multiline_field_from_text (length (full_fieldname), message_text_user_field.text, 872 header_field_value); 873 end; 874 else do; 875 message_text_user_field.text_ptr = addr (header_field_value); 876 message_text_user_field.text_lth = length (header_field_value); 877 end; 878 879 position = -1; /* add it to the end, please */ 880 call add_user_field (message_ptr, addr (local_mufp), position, "1"b, code); 881 if code ^= 0 then do; 882 if message_text_user_field.multiline_text then free message_text_user_field_text in (system_area); 883 call message_parse_error_fatal (code); 884 end; 885 886 if message_text_user_field.multiline_text then 887 if message_text_user_field.text_ptr 888 ^= addr (message_user_fields_list.user_fields (position)) -> message_text_user_field.text_ptr 889 then 890 free message_text_user_field_text in (system_area); 891 end; 892 893 894 /* Convert all free-standing comment fields into user-defined fields: A free-standing comment is any Comment text field 895* in the message for which the scanner didn't find matching Comment-Date and Comment-By fields */ 896 897 local_mufp.version = MESSAGE_USER_FIELD_PARAMETER_VERSION_2; 898 message_user_field_ptr = addr (local_mufp.user_field); 899 900 call mail_system_$get_user_field_id ("X-Comments", message_user_field.field_id, (""), code); 901 if (code ^= 0) & (code ^= error_table_$smallarg) then call message_parse_error_fatal (code); 902 /* must use above name to avoid conflicts */ 903 904 message_user_field.field_type = MESSAGE_TEXT_USER_FIELD; 905 message_text_user_field.multiline_text = "1"b; 906 message_text_user_field.text_ptr = null (); /* no previous text */ 907 message_text_user_field.text_lth = 0; 908 909 current_field_list_idx = 1; 910 911 do while (current_field_list_idx <= comment_info_list.n_comment_infos); 912 913 comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx); 914 915 if (comment_info.types (DATE_FIELD).n_fields = 0) & (comment_info.types (SENDER_FIELD).n_fields = 0) 916 then do; /* this "commenting" should be a user field */ 917 call prepare_multiline_field_from_list (length ("X-Comments"), message_text_user_field.text, 918 addr (comment_info.types (COMMENT_FIELD))); 919 free comment_info in (system_area); /* we don't need it anymore */ 920 do idx = (current_field_list_idx + 1) to comment_info_list.n_comment_infos; 921 comment_info_list.comment_info_ptrs (idx - 1) = comment_info_list.comment_info_ptrs (idx); 922 end; 923 comment_info_list.n_comment_infos = comment_info_list.n_comment_infos - 1; 924 end; 925 926 else current_field_list_idx = current_field_list_idx + 1; 927 end; /* a real commenting operation */ 928 929 if message_text_user_field.text_ptr ^= null () then do; 930 position = -1; /* found some: add them to the message */ 931 call add_user_field (message_ptr, addr (local_mufp), position, "1"b, code); 932 if code ^= 0 then do; 933 free message_text_user_field_text in (system_area); 934 call message_parse_error_fatal (code); 935 end; 936 if message_text_user_field.text_ptr 937 ^= addr (message_user_fields_list.user_fields (position)) -> message_text_user_field.text_ptr then 938 free message_text_user_field_text in (system_area); 939 end; 940 941 942 if new_message then do; 943 944 /* New Message -- Mark any redistributions and any remaining comments as errors */ 945 946 do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos; 947 forwarding_info_ptr = forwarding_info_list.forwarding_info_ptrs (current_field_list_idx); 948 do idx = 1 to N_ORDINARY_FIELDS; 949 call mark_as_in_mailbox_field (addr (forwarding_info.types (idx))); 950 end; 951 end; 952 953 do current_field_list_idx = 1 to comment_info_list.n_comment_infos; 954 comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx); 955 do idx = 1 to N_ORDINARY_FIELDS; 956 call mark_as_in_mailbox_field (addr (comment_info.types (idx))); 957 end; 958 end; 959 end; 960 961 962 else do; /* in-mailbox/incoming */ 963 if (forwarding_info_list.n_forwarding_infos = 0) & (comment_info_list.n_comment_infos > 0) then do; 964 do current_field_list_idx = 1 to comment_info_list.n_comment_infos; 965 comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx); 966 call find_first_field_in_list (comment_info_ptr, field_idx); 967 call message_parse_error (parse_text_options, mlsys_et_$no_comment_redistribution, 968 header_field_list.fields (field_idx).complete_field_start, 969 header_field_list.fields (field_idx).complete_field_lth, "The comment which starts with:"); 970 end; 971 end; 972 973 974 /* In-mailbox/Incoming Message -- Parse the redistributions list */ 975 976 if forwarding_info_list.n_forwarding_infos > 0 then do; 977 978 allocate mr_sort in (system_area) set (mr_sort_ptr); 979 allocate mrps in (system_area) set (mrps_ptr); 980 981 mrps (*).version = MESSAGE_REDISTRIBUTION_PARAMETER_VERSION_2; 982 mrps (*).sender, mrps (*).trace, mrps (*).delivered_by, mrps (*).acknowledge_to, mrps (*).from, 983 mrps (*).to, mrps (*).comment.text_ptr = null (); 984 985 do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos; 986 the_mrp_ptr = addr (mrps (current_field_list_idx)); 987 988 forwarding_info_ptr = forwarding_info_list.forwarding_info_ptrs (current_field_list_idx); 989 call find_first_field_in_list (forwarding_info_ptr, first_field_idx); 990 991 call parse_envelope (parse_text_options, internal_parse_options, "1"b, forwarding_info_ptr, 992 addr (the_mrp.envelope), the_mrp.date_time_created, the_mrp.from); 993 994 if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields = 1 then do; 995 field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (1); 996 call parse_message_id_text (parse_text_options, internal_parse_options, header_field_value, 997 the_mrp.message_id); 998 end; 999 else if field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields > 1 then do; 1000 do idx = 1 to field_by_type_lists.types (MESSAGE_ID_FIELD).n_fields; 1001 field_idx = field_by_type_lists.types (MESSAGE_ID_FIELD).field_idxs (idx); 1002 call message_parse_error (parse_text_options, mlsys_et_$extra_restricted_field, 1003 header_field_list.fields (field_idx).complete_field_start, 1004 header_field_list.fields (field_idx).complete_field_lth, ""); 1005 end; 1006 end; 1007 else do; /* must construct a psudeo ID */ 1008 if (the_mrp.date_time_created ^= 0) & (the_mrp.from -> address_list.n_addresses > 0) then 1009 call encode_psuedo_id (the_mrp.date_time_created, the_mrp.from, 1010 internal_parse_options.default_system_name, the_mrp.message_id); 1011 else call message_parse_error (parse_text_options, mlsys_et_$cant_determine_msgid, 1012 header_field_list.fields (first_field_idx).complete_field_start, 1013 header_field_list.fields (first_field_idx).complete_field_lth, 1014 "The redistribution which starts with:"); 1015 end; 1016 1017 full_fieldname = REDISTRIBUTED_PREFIX || TO_FIELDNAME; 1018 if forwarding_info.types (TO_FIELD).n_fields > 0 then 1019 call parse_address_list_field (parse_text_options, internal_parse_options, full_fieldname, 1020 addr (forwarding_info.types (TO_FIELD)), the_mrp.to); 1021 1022 if forwarding_info.types (COMMENT_FIELD).n_fields > 0 then 1023 call prepare_multiline_field_from_list (length (REDISTRIBUTED_COMMENT_FIELDNAME), 1024 the_mrp.comment, addr (forwarding_info.types (COMMENT_FIELD))); 1025 end; 1026 1027 1028 /* In-mailbox/Incoming message -- Find any old-style redistribution comments (Comment-Date/Comment-By/Comment) and place 1029* their text into the appropriate redistribution */ 1030 1031 internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name (); 1032 internal_parse_options.default_system_is_local = "1"b; 1033 1034 do current_field_list_idx = 1 to comment_info_list.n_comment_infos; 1035 comment_info_ptr = comment_info_list.comment_info_ptrs (current_field_list_idx); 1036 call find_first_field_in_list (comment_info_ptr, first_field_idx); 1037 1038 if (comment_info.types (DATE_FIELD).n_fields = 0) 1039 | (comment_info.types (SENDER_FIELD).n_fields = 0) then 1040 call message_parse_error (parse_text_options, mlsys_et_$incomplete_comment, 1041 header_field_list.fields (first_field_idx).complete_field_start, 1042 header_field_list.fields (first_field_idx).complete_field_lth, 1043 "The comment which starts with:"); 1044 1045 else do; 1046 /*** Message scanner guarentees at most one Comment-Date and Comment-By */ 1047 field_idx = comment_info.types (DATE_FIELD).field_idxs (1); 1048 call parse_date_time_text (parse_text_options, internal_parse_options, header_field_value, 1049 comment_date_time_created, code); 1050 if code ^= 0 then do; 1051 call message_parse_error (parse_text_options, code, 1052 header_field_list.fields (field_idx).complete_field_start, 1053 header_field_list.fields (field_idx).complete_field_lth, ""); 1054 call message_parse_error (parse_text_options, mlsys_et_$comment_ignored, 1055 header_field_list.fields (first_field_idx).complete_field_start, 1056 header_field_list.fields (first_field_idx).complete_field_lth, 1057 "The comment which starts with:"); 1058 go to TRY_NEXT_COMMENT_OPERATION; 1059 end; 1060 1061 field_idx = comment_info.types (SENDER_FIELD).field_idxs (1); 1062 call parse_address_text_internal (parse_text_options, internal_parse_options, 1063 header_field_value, comment_sender, code); 1064 if code ^= 0 then do; 1065 call message_parse_error (parse_text_options, code, 1066 header_field_list.fields (field_idx).complete_field_start, 1067 header_field_list.fields (field_idx).complete_field_lth, ""); 1068 call message_parse_error (parse_text_options, mlsys_et_$comment_ignored, 1069 header_field_list.fields (first_field_idx).complete_field_start, 1070 header_field_list.fields (first_field_idx).complete_field_lth, 1071 "The comment which starts with:"); 1072 go to TRY_NEXT_COMMENT_OPERATION; 1073 end; 1074 1075 do idx = 1 to forwarding_info_list.n_forwarding_infos; 1076 if mrps (idx).sender = null () then 1077 redistribution_sender = mrps (idx).from -> address_list.addresses (1); 1078 else redistribution_sender = mrps (idx).sender; 1079 if date_time_equal (comment_date_time_created, mrps (idx).date_time_created) 1080 & mail_system_$compare_addresses (comment_sender, redistribution_sender, (0)) 1081 then do; 1082 if comment_info.types (COMMENT_FIELD).n_fields > 0 then 1083 call prepare_multiline_field_from_list (length ("Comment"), 1084 mrps (idx).comment, addr (comment_info.types (COMMENT_FIELD))); 1085 call mail_system_$free_address (comment_sender, (0)); 1086 go to TRY_NEXT_COMMENT_OPERATION; 1087 end; 1088 end; 1089 1090 /*** Control arrives here iff we couldn't find the matching redistribution */ 1091 call message_parse_error (parse_text_options, mlsys_et_$no_comment_redistribution, 1092 header_field_list.fields (first_field_idx).complete_field_start, 1093 header_field_list.fields (first_field_idx).complete_field_lth, 1094 "The comment which starts with:"); 1095 end; 1096 1097 TRY_NEXT_COMMENT_OPERATION: 1098 end; 1099 1100 1101 /* In-mailbox/Incoming Message -- Sort the redistributions into chronological order; redistributions whose date/time 1102* created is unkown will be placed at the beginning of the list */ 1103 1104 n_sorted = 0; /* nothing's sorted yet */ 1105 1106 do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos; 1107 the_mrp_ptr = addr (mrps (current_field_list_idx)); 1108 1109 sort_idx = 0; 1110 do idx = 1 to n_sorted while (sort_idx = 0); 1111 if date_time_before (the_mrp.date_time_created, mrps (mr_sort (idx)).date_time_created) then 1112 sort_idx = idx; 1113 end; 1114 if sort_idx = 0 then /* this is the oldest one now */ 1115 sort_idx = n_sorted + 1; 1116 1117 do idx = n_sorted to sort_idx by -1; 1118 mr_sort (idx + 1) = mr_sort (idx); 1119 end; /* move older fields up */ 1120 1121 mr_sort (sort_idx) = current_field_list_idx; 1122 n_sorted = n_sorted + 1; 1123 end; 1124 end; 1125 1126 1127 /* In-mailbox/Incoming Message -- Determine where the "original" message trace belongs as only Multics uses the 1128* "Redistributed-" forms of the message trace fields */ 1129 1130 if (local_mep.trace ^= null ()) & (forwarding_info_list.n_forwarding_infos > 0) then 1131 if local_mep.trace -> message_trace.n_relays > 0 then do; 1132 message_trace_ptr = local_mep.trace; 1133 date_time_last_relayed = message_trace.relays (message_trace.n_relays).date_time_relayed; 1134 1135 do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos; 1136 idx = mr_sort (current_field_list_idx); 1137 if date_time_before (date_time_last_relayed, mrps (idx).date_time_created) then do; 1138 if idx = 1 then go to ORIGINAL_TRACE_PROPERLY_PLACED; 1139 if mrps (idx - 1).date_time_created = 0 then go to ORIGINAL_TRACE_PROPERLY_PLACED; 1140 if mrps (idx - 1).trace ^= null () then go to ORIGINAL_TRACE_PROPERLY_PLACED; 1141 mrps (idx - 1).trace = local_mep.trace; 1142 local_mep.trace = null (); 1143 go to ORIGINAL_TRACE_PROPERLY_PLACED; 1144 end; 1145 end; 1146 1147 /*** Control arrives here iff the trace should be attached to the last redistribution */ 1148 if (mrps (forwarding_info_list.n_forwarding_infos).date_time_created ^= 0) 1149 & (mrps (forwarding_info_list.n_forwarding_infos).trace = null ()) then do; 1150 mrps (forwarding_info_list.n_forwarding_infos).trace = local_mep.trace; 1151 local_mep.trace = null (); 1152 end; 1153 1154 ORIGINAL_TRACE_PROPERLY_PLACED: 1155 end; 1156 1157 1158 /* In-mailbox/Incoming Message -- Set the Acknowledge-To fields */ 1159 1160 acknowledge_to = null (); 1161 1162 if internal_parse_options.requests_acknowledgement then do; 1163 do current_field_list_idx = forwarding_info_list.n_forwarding_infos to 1 by -1 1164 while (acknowledge_to = null ()); 1165 idx = mr_sort (current_field_list_idx); 1166 if mrps (idx).acknowledge_to ^= null () then acknowledge_to = mrps (idx).acknowledge_to; 1167 end; 1168 1169 if acknowledge_to = null () then acknowledge_to = local_mep.acknowledge_to; 1170 if acknowledge_to = null () then acknowledge_to = internal_parse_options.last_delivered_by; 1171 end; 1172 1173 if forwarding_info_list.n_forwarding_infos = 0 then do; 1174 if (local_mep.acknowledge_to ^= null ()) & (local_mep.acknowledge_to ^= acknowledge_to) then 1175 call mail_system_$free_address (local_mep.acknowledge_to, (0)); 1176 local_mep.acknowledge_to = acknowledge_to; 1177 end; 1178 1179 else do; /* put it in the last redistribution */ 1180 idx = mr_sort (forwarding_info_list.n_forwarding_infos); 1181 if (mrps (idx).acknowledge_to ^= null ()) & (mrps (idx).acknowledge_to ^= acknowledge_to) then 1182 call mail_system_$free_address (mrps (idx).acknowledge_to, (0)); 1183 1184 mrps (idx).acknowledge_to = acknowledge_to; 1185 1186 do current_field_list_idx = 1 to (forwarding_info_list.n_forwarding_infos - 1); 1187 idx = mr_sort (current_field_list_idx); 1188 if (mrps (idx).acknowledge_to ^= null ()) & (mrps (idx).acknowledge_to ^= acknowledge_to) then 1189 call mail_system_$free_address (mrps (idx).acknowledge_to, (0)); 1190 else mrps (idx).acknowledge_to = null (); 1191 end; 1192 1193 if (local_mep.acknowledge_to ^= null ()) & (local_mep.acknowledge_to ^= acknowledge_to) then 1194 call mail_system_$free_address (local_mep.acknowledge_to, (0)); 1195 else local_mep.acknowledge_to = null ();/* message should hve only one Acknowledge-To field */ 1196 end; 1197 1198 1199 /* In-mailbox/Incoming Message -- If supplied, set the last delivery date and address to the values from ring-1 and then 1200* place the envelope and redistributions list into the message */ 1201 1202 if internal_parse_options.last_delivered_by ^= null () then 1203 if forwarding_info_list.n_forwarding_infos = 0 then do; 1204 local_mep.date_time_delivered = internal_parse_options.last_date_time_delivered; 1205 if local_mep.delivered_by ^= null () then 1206 call mail_system_$free_address (local_mep.delivered_by, (0)); 1207 if local_mep.sender ^= null () then 1208 if mail_system_$compare_addresses (local_mep.sender, 1209 internal_parse_options.last_delivered_by, (0)) then 1210 ; 1211 else local_mep.delivered_by = internal_parse_options.last_delivered_by; 1212 else /*** if local_mep.sender = null () then */ 1213 if 1214 mail_system_$compare_addresses (message.from -> address_list.addresses (1), 1215 internal_parse_options.last_delivered_by, (0)) then 1216 ; 1217 else local_mep.delivered_by = internal_parse_options.last_delivered_by; 1218 end; 1219 1220 else do; 1221 the_mrp_ptr = addr (mrps (mr_sort (forwarding_info_list.n_forwarding_infos))); 1222 the_mrp.date_time_delivered = internal_parse_options.last_date_time_delivered; 1223 if the_mrp.delivered_by ^= null () then 1224 call mail_system_$free_address (the_mrp.delivered_by, (0)); 1225 if the_mrp.sender ^= null () then 1226 if mail_system_$compare_addresses (the_mrp.sender, internal_parse_options.last_delivered_by, 1227 (0)) then 1228 ; 1229 else the_mrp.delivered_by = internal_parse_options.last_delivered_by; 1230 else /*** if the_mrp.sender = null () then */ 1231 if 1232 mail_system_$compare_addresses (the_mrp.from -> address_list.addresses (1), 1233 internal_parse_options.last_delivered_by, (0)) then 1234 ; 1235 else the_mrp.delivered_by = internal_parse_options.last_delivered_by; 1236 end; 1237 1238 call replace_message_envelope (message_ptr, addr (local_mep), code); 1239 if code ^= 0 then call message_parse_error_fatal (code); 1240 local_mep.sender, local_mep.delivered_by, local_mep.acknowledge_to = null (); 1241 1242 do current_field_list_idx = 1 to forwarding_info_list.n_forwarding_infos; 1243 idx = mr_sort (current_field_list_idx); 1244 the_mrp_ptr = addr (mrps (idx)); 1245 position = -1; /* add it to the end please */ 1246 call add_redistribution (message_ptr, the_mrp_ptr, position, code); 1247 if code ^= 0 then call message_parse_error_fatal (code); 1248 the_mrp.sender, the_mrp.delivered_by, the_mrp.acknowledge_to = null (); 1249 message_redistribution_ptr = addr (message_redistributions_list.redistributions (position)); 1250 if the_mrp.from = message_redistribution.from then the_mrp.from = null (); 1251 if the_mrp.to = message_redistribution.to then the_mrp.to = null (); 1252 if the_mrp.comment.text_ptr = message_redistribution.comment.text_ptr then 1253 the_mrp.comment.text_ptr = null ();/* don't leave it to be freed if it's used directly */ 1254 end; 1255 1256 1257 /* In-mailbox/Incoming Message -- Set the implicit route for all addresses as appropriate */ 1258 1259 if message.envelope.trace ^= null () then 1260 if message.envelope.trace -> message_trace.implicit_route ^= null () then do; 1261 implicit_route = message.envelope.trace -> message_trace.implicit_route; 1262 call set_implicit_route (message.from, implicit_route); 1263 call set_implicit_route (message.reply_to, implicit_route); 1264 call set_implicit_route (message.to, implicit_route); 1265 call set_implicit_route (message.cc, implicit_route); 1266 call set_implicit_route (message.bcc, implicit_route); 1267 do idx = 1 to message.n_user_fields; 1268 message_user_field_ptr = addr (message_user_fields_list.user_fields (idx)); 1269 if message_user_field.field_type = MESSAGE_ADDRESS_LIST_USER_FIELD then 1270 call set_implicit_route (message_address_list_user_field.address_list_ptr, 1271 implicit_route); 1272 end; 1273 end; 1274 1275 do idx = 1 to message.n_redistributions; 1276 message_redistribution_ptr = addr (message_redistributions_list.redistributions (idx)); 1277 if message_redistribution.envelope.trace ^= null () then 1278 if message_redistribution.envelope.trace -> message_trace.implicit_route ^= null () then do; 1279 implicit_route = message_redistribution.envelope.trace -> message_trace.implicit_route; 1280 call set_implicit_route (message_redistribution.from, implicit_route); 1281 call set_implicit_route (message_redistribution.to, implicit_route); 1282 end; 1283 end; 1284 end; 1285 1286 1287 /* Control arrives here iff the message parse succeeded */ 1288 1289 call cleanup_message_parse_data (); /* get rid of all temporaries */ 1290 1291 P_message_ptr = message_ptr; /* pass the message back to our caller */ 1292 1293 if parse_text_options.list_errors then /* will never be set by entries without this parameter */ 1294 P_parse_text_error_list_ptr = parse_text_error_list_ptr; 1295 1296 if message_parse_fails then /* some types of errors were detected ... */ 1297 P_code = mlsys_et_$text_parse_failed; /* ... even though we might return a message structure */ 1298 else P_code = 0; 1299 1300 return; 1301 1302 /* Convert the external form of a mailing list (an ASCII segment/archive component containing the printed representation 1303* of addresses) into its internal representation: This operation is identical to parse_address_list_text except that 1304* each line in a mailing list is considered a separate list unless, of course, a single address spans multiple lines; in 1305* addition, the lines in a mailing list may contain an optional trailing comma */ 1306 1307 parse_mailing_list_text: 1308 entry (P_representation, P_address_list_version, P_address_list_ptr, P_code); 1309 1310 local_pto.area_ptr = null (); /* setup standard parse options */ 1311 string (local_pto.flags) = ""b; 1312 local_pto.list_errors = "1"b; /* see below */ 1313 local_pto.include_invalid_addresses = "1"b; 1314 parse_text_options_ptr = addr (local_pto); 1315 1316 string (internal_parse_options.flags) = ""b; 1317 internal_parse_options.multics_format = "1"b; /* use standard Multics formatting conventions */ 1318 internal_parse_options.no_copy = "0"b; /* can't use supplied text directly (sigh) */ 1319 1320 internal_parse_options.default_system_is_local = "1"b; 1321 internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name (); 1322 1323 string (internal_parse_options.delimiters) = ""b; /* terminate corectly only at the end of the string */ 1324 internal_parse_options.delimiters.eos = "1"b; 1325 1326 system_area_ptr = get_system_free_area_ (); 1327 1328 add_address = mlsys_address_list_mgr_$add_address; 1329 create_address_list = mlsys_address_list_mgr_$create_user_freeable_address_list; 1330 delete_address = mlsys_address_list_mgr_$delete_address; 1331 free_address_list = mlsys_address_list_mgr_$free_address_list; 1332 1333 address_list_ptr, /* for cleanup handler */ 1334 lex_and_parse_pointers, forum_search_list_ptr = null (); 1335 1336 on condition (cleanup) 1337 begin; 1338 if address_list_ptr ^= null () then call mlsys_address_list_mgr_$free_address_list (address_list_ptr, (0)); 1339 call lex_and_parse_epilogue ("1"b); 1340 if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area); 1341 forum_search_list_ptr = null (); 1342 end; 1343 1344 call mlsys_address_list_mgr_$create_user_freeable_address_list (P_address_list_version, address_list_ptr, code); 1345 if code ^= 0 then do; /* probably asked for the wrong version */ 1346 P_code = code; 1347 return; 1348 end; 1349 1350 representation_ptr = addr (P_representation); 1351 representation_lth = length (P_representation); 1352 representation_used = 0; /* haven't parsed any of it yet */ 1353 1354 eol_idx = index (representation, NL); /* start with first line in the mailing list */ 1355 if eol_idx = 0 then eol_idx = length (representation) + 1; 1356 1357 do while (representation_used < representation_lth); 1358 1359 begin; /* try to parse the next section (usually a line) */ 1360 1361 dcl text_to_parse character (eol_idx - 1) unaligned defined (representation) position (representation_used + 1); 1362 1363 if verify (text_to_parse, WHITESPACE) = 0 then 1364 n_syntax_errors = 0; /* ingore blank lines */ 1365 else call parse_address_list_text_internal (parse_text_options, internal_parse_options, text_to_parse, 1366 address_list_ptr, code); 1367 1368 if (n_syntax_errors > 0) & ((representation_used + eol_idx) < representation_lth) then do; 1369 1370 /*** Check for errors which can be generated if the last address in this section is incomplete */ 1371 if (sel (1).code = mlsys_et_$unbalanced_braces) | (sel (1).code = mlsys_et_$unbalanced_quotes) 1372 | (sel (1).code = mlsys_et_$unbalanced_parentheses) then do; 1373 call mlsys_address_list_mgr_$delete_address (address_list_ptr, address_list.n_addresses, 1374 (0)); 1375 amount_good = 0; /* try entire section again with next line */ 1376 end; 1377 1378 else if sel (n_syntax_errors).code = mlsys_et_$invalid_named_group_text then 1379 if (sel (n_syntax_errors).text_start + sel (n_syntax_errors).text_lth) 1380 >= length (text_to_parse) then do; 1381 call mlsys_address_list_mgr_$delete_address (address_list_ptr, 1382 address_list.n_addresses, (0)); 1383 amount_good = sel (n_syntax_errors).text_start - 1; 1384 end; /* try bad named group again with next line */ 1385 else amount_good = length (text_to_parse); 1386 1387 else if sel (n_syntax_errors).code = mlsys_et_$empty_address_text then do; 1388 if (sel (n_syntax_errors).text_start + sel (n_syntax_errors).text_lth) 1389 >= length (text_to_parse) then do; 1390 begin; 1391 dcl empty_text character (sel (n_syntax_errors).text_lth) unaligned defined (representation) 1392 position (representation_used + sel (n_syntax_errors).text_start); 1393 if verify (empty_text, WHITESPACE) = 0 then 1394 call mlsys_address_list_mgr_$delete_address (address_list_ptr, 1395 address_list.n_addresses, (0)); 1396 end; 1397 amount_good = length (text_to_parse); 1398 end; 1399 1400 else amount_good = length (text_to_parse); 1401 end; 1402 1403 else amount_good = length (text_to_parse); 1404 end; 1405 1406 else amount_good = length (text_to_parse); 1407 end; 1408 1409 if (representation_used + amount_good) < representation_lth then do; 1410 begin; /* find end of next line beyond current section */ 1411 dcl rest_of_representation character (representation_lth - representation_used - eol_idx) unaligned 1412 defined (representation) position (representation_used + eol_idx); 1413 next_eol_idx = index (rest_of_representation, NL); 1414 if next_eol_idx = 0 then next_eol_idx = length (rest_of_representation) + 1; 1415 end; 1416 eol_idx = eol_idx - amount_good + next_eol_idx; 1417 representation_used = representation_used + amount_good; 1418 end; 1419 else representation_used = representation_lth; 1420 1421 call lex_and_parse_epilogue ("1"b); /* get rid of syntax error list */ 1422 end; 1423 1424 P_address_list_ptr = address_list_ptr; /* success */ 1425 P_code = 0; 1426 1427 return; 1428 1429 /* Convert the printed representation of an address list into its internal representation */ 1430 1431 parse_address_list_text: 1432 entry (P_representation, P_parse_text_options_ptr, P_address_list_version, P_address_list_ptr, 1433 P_parse_text_error_list_ptr, P_code); 1434 1435 parse_text_options_ptr = P_parse_text_options_ptr; 1436 if parse_text_options.version ^= PARSE_TEXT_OPTIONS_VERSION_1 then do; 1437 P_code = error_table_$unimplemented_version; 1438 return; 1439 end; 1440 if parse_text_options.mbz ^= ""b then do; 1441 P_code = error_table_$bad_subr_arg; 1442 return; 1443 end; 1444 1445 add_address = mail_system_$add_address; 1446 create_address_list = mail_system_$create_address_list; 1447 delete_address = mail_system_$delete_address; 1448 free_address_list = mail_system_$free_address_list; 1449 1450 system_area_ptr = get_system_free_area_ (); 1451 1452 if parse_text_options.area_ptr = null () then 1453 user_area_ptr = get_system_free_area_ (); 1454 else user_area_ptr = parse_text_options.area_ptr; 1455 1456 string (internal_parse_options.flags) = ""b; 1457 internal_parse_options.multics_format = "1"b; /* use standard Multics formatting conventions */ 1458 internal_parse_options.no_copy = "0"b; /* can't use supplied text directly */ 1459 1460 internal_parse_options.default_system_is_local = "1"b; 1461 internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name (); 1462 1463 string (internal_parse_options.delimiters) = ""b; /* terminate corectly only at the end of the string */ 1464 internal_parse_options.delimiters.eos = "1"b; 1465 1466 address_list_ptr, /* for cleanup handler */ 1467 lex_and_parse_pointers, forum_search_list_ptr = null (); 1468 1469 on condition (cleanup) 1470 begin; 1471 if address_list_ptr ^= null () then call mail_system_$free_address_list (address_list_ptr, (0)); 1472 call lex_and_parse_epilogue ("1"b); 1473 if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area); 1474 forum_search_list_ptr = null (); 1475 end; 1476 1477 call mail_system_$create_address_list (P_address_list_version, address_list_ptr, code); 1478 if code ^= 0 then do; /* probably asked for the wrong version */ 1479 P_code = code; 1480 return; 1481 end; 1482 1483 call parse_address_list_text_internal (parse_text_options, internal_parse_options, P_representation, 1484 address_list_ptr, code); 1485 1486 if code ^= 0 then /* iff caller requested an error free list */ 1487 call mail_system_$free_address_list (address_list_ptr, (0)); 1488 1489 if parse_text_options.list_errors & (n_syntax_errors > 0) then do; 1490 parse_text_error_list_n_errors = n_syntax_errors; 1491 allocate parse_text_error_list in (system_area) set (parse_text_error_list_ptr); 1492 do idx = 1 to parse_text_error_list.n_errors; 1493 parse_text_error_list.errors (idx).text_start = sel (idx).text_start; 1494 parse_text_error_list.errors (idx).text_lth = sel (idx).text_lth; 1495 parse_text_error_list.errors (idx).code = sel (idx).code; 1496 parse_text_error_list.errors (idx).additional_info = ""; 1497 end; 1498 end; 1499 else parse_text_error_list_ptr = null (); 1500 1501 call lex_and_parse_epilogue ("1"b); /* get rid of syntax error list now */ 1502 1503 P_address_list_ptr = address_list_ptr; 1504 P_parse_text_error_list_ptr = parse_text_error_list_ptr; 1505 1506 if n_syntax_errors > 0 then /* something went wrong: let caller know ... */ 1507 P_code = mlsys_et_$text_parse_failed; /* ... even though they might still be getting a list back */ 1508 else P_code = 0; 1509 1510 return; 1511 1512 1513 1514 /* Actually lexically analyze and parse the address list text (called from several different entrypoints) */ 1515 1516 parse_address_list_text_internal: 1517 procedure (p_pto, p_ipo, p_representation, p_address_list_ptr, p_code) /* options (quick) */; 1518 1519 dcl 1 p_pto aligned like parse_text_options parameter; 1520 dcl 1 p_ipo aligned like internal_parse_options parameter; 1521 dcl p_representation character (*) parameter; 1522 dcl p_address_list_ptr pointer parameter; 1523 dcl p_code fixed binary (35) parameter; 1524 1525 dcl bad_address pointer; 1526 1527 call lex_and_parse_prologue (p_representation, "1"b, "1"b); 1528 /* lex of an address with syntax list */ 1529 1530 call lex_address (p_pto, p_ipo, p_code); /* convert it into a token list */ 1531 1532 if p_code = 0 then /* lex worked: try parsing it */ 1533 call parse_address_list (p_pto, p_ipo, 0, p_address_list_ptr, p_code); 1534 else do; /* lex failed: record one error */ 1535 n_syntax_errors = 1; 1536 if p_pto.list_errors then do; 1537 sel (1).text_start = 1; 1538 sel (1).text_lth = length (p_representation); 1539 sel (1).code = p_code; 1540 end; 1541 if p_pto.include_invalid_addresses then do; 1542 call mail_system_$create_invalid_address ((p_representation), "", "", bad_address, (0)); 1543 call add_address (p_address_list_ptr, bad_address, ADDRESS_LIST_VERSION_2, (0)); 1544 p_code = 0; /* claim success */ 1545 end; 1546 end; 1547 1548 call lex_and_parse_epilogue ("0"b); /* cleanup */ 1549 1550 return; 1551 1552 end parse_address_list_text_internal; 1553 1554 /* Convert the printed representation of an address into its internal representation */ 1555 1556 parse_address_text: 1557 entry (P_representation, P_address_ptr, P_code); 1558 1559 add_address = mail_system_$add_address; 1560 create_address_list = mail_system_$create_address_list; 1561 delete_address = mail_system_$delete_address; 1562 free_address_list = mail_system_$free_address_list; 1563 1564 system_area_ptr = get_system_free_area_ (); 1565 1566 parse_text_options_ptr = addr (local_pto); /* caller doesn't supply this structure */ 1567 string (local_pto.flags) = ""b; /* ... don't list, validate, or create invalid addresses */ 1568 1569 internal_parse_options.multics_format = "1"b; /* use standard Multics formatting conventions */ 1570 internal_parse_options.no_copy = "0"b; /* can't use supplied text directly */ 1571 1572 internal_parse_options.default_system_is_local = "1"b; 1573 internal_parse_options.default_system_name = mlsys_nit_interface_$get_local_system_name (); 1574 1575 string (internal_parse_options.delimiters) = ""b; /* terminate corectly only at the end of the string */ 1576 internal_parse_options.delimiters.eos = "1"b; 1577 1578 lex_and_parse_pointers, /* for cleanup handler */ 1579 forum_search_list_ptr = null (); 1580 1581 on condition (cleanup) 1582 begin; 1583 call lex_and_parse_epilogue ("1"b); 1584 if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area); 1585 forum_search_list_ptr = null (); 1586 end; 1587 1588 call parse_address_text_internal (parse_text_options, internal_parse_options, P_representation, address_ptr, 1589 code); 1590 1591 if code = 0 then /* successfully parsed an address from the string */ 1592 P_address_ptr = address_ptr; 1593 1594 P_code = code; 1595 1596 return; 1597 1598 1599 1600 /* Actually lexically analyze and parse the address text (called from several different entrypoints) */ 1601 1602 parse_address_text_internal: 1603 procedure (p_pto, p_ipo, p_representation, p_address_ptr, p_code) /* options (quick) */; 1604 1605 dcl 1 p_pto aligned like parse_text_options parameter; 1606 dcl 1 p_ipo aligned like internal_parse_options parameter; 1607 dcl p_representation character (*) parameter; 1608 dcl p_address_ptr pointer parameter; 1609 dcl p_code fixed binary (35) parameter; 1610 1611 call lex_and_parse_prologue (p_representation, "1"b, "0"b); 1612 /* lex of an address without syntax list */ 1613 1614 call lex_address (p_pto, p_ipo, p_code); /* convert it into a token list */ 1615 1616 if p_code = 0 then /* lex worked: try parsing it */ 1617 call parse_address (p_pto, p_ipo, 0, p_address_ptr, p_code); 1618 1619 call lex_and_parse_epilogue ("1"b); /* cleanup */ 1620 call cu_$shrink_stack_frame (stack_extension_ptr, (0)); 1621 1622 return; 1623 1624 end parse_address_text_internal; 1625 1626 /* Initialize data structures used during parsing of a message */ 1627 1628 initialize_message_parse_data: 1629 procedure (); 1630 1631 message_scan.array_pointers, lex_and_parse_pointers, parse_text_error_list_ptr, mrps_ptr, mr_sort_ptr, 1632 trace_address, comment_sender, local_mep.sender, local_mep.trace, local_mep.delivered_by, 1633 local_mep.acknowledge_to, address_list_field, forum_search_list_ptr = null (); 1634 1635 return; 1636 1637 end initialize_message_parse_data; 1638 1639 1640 1641 /* Release interim data structures created during parsing of a message */ 1642 1643 cleanup_message_parse_data: 1644 procedure (); 1645 1646 dcl (idx, jdx) fixed binary; 1647 1648 if forum_search_list_ptr ^= null () then free forum_search_list_ptr -> sl_info in (system_area); 1649 forum_search_list_ptr = null (); 1650 1651 if address_list_field ^= null () then call free_address_list (address_list_field, (0)); 1652 1653 if local_mep.sender ^= null () then call mail_system_$free_address (local_mep.sender, (0)); 1654 if local_mep.trace ^= null () then do; 1655 if local_mep.trace -> message_trace.implicit_route ^= null () then 1656 free local_mep.trace -> message_trace.implicit_route -> address_route in (system_area); 1657 do idx = 1 to local_mep.trace -> message_trace.n_relays; 1658 if local_mep.trace -> message_trace.relays (idx).relay_recipient ^= null () then 1659 call mail_system_$free_address (local_mep.trace -> message_trace.relays (idx).relay_recipient, 1660 (0)); 1661 end; 1662 free local_mep.trace -> message_trace in (system_area); 1663 local_mep.trace = null (); 1664 end; 1665 if local_mep.delivered_by ^= null () then call mail_system_$free_address (local_mep.delivered_by, (0)); 1666 if local_mep.acknowledge_to ^= null () then call mail_system_$free_address (local_mep.acknowledge_to, (0)); 1667 1668 if mrps_ptr ^= null () then do; 1669 do idx = 1 to forwarding_info_list.n_forwarding_infos; 1670 if mrps (idx).sender ^= null () then call mail_system_$free_address (mrps (idx).sender, (0)); 1671 if mrps (idx).trace ^= null () then do; 1672 if mrps (idx).trace -> message_trace.implicit_route ^= null () then 1673 free mrps (idx).trace -> message_trace.implicit_route -> address_route in (system_area); 1674 do jdx = 1 to mrps (idx).trace -> message_trace.n_relays; 1675 if mrps (idx).trace -> message_trace.relays (jdx).relay_recipient ^= null () then 1676 call mail_system_$free_address (mrps (idx).trace 1677 -> message_trace.relays (jdx).relay_recipient, (0)); 1678 end; 1679 free mrps (idx).trace -> message_trace in (system_area); 1680 mrps (idx).trace = null (); 1681 end; 1682 if mrps (idx).delivered_by ^= null () then 1683 call mail_system_$free_address (mrps (idx).delivered_by, (0)); 1684 if mrps (idx).acknowledge_to ^= null () then 1685 call mail_system_$free_address (mrps (idx).acknowledge_to, (0)); 1686 if mrps (idx).from ^= null () then call free_address_list (mrps (idx).from, (0)); 1687 if mrps (idx).to ^= null () then call free_address_list (mrps (idx).to, (0)); 1688 if mrps (idx).comment.text_ptr ^= null () then 1689 /* there's some text ... */ 1690 begin; 1691 dcl the_comment character (mrps (idx).comment.text_lth) unaligned based (mrps (idx).comment.text_ptr); 1692 free the_comment in (system_area); 1693 mrps (idx).comment.text_ptr = null (); 1694 end; 1695 end; 1696 free mrps in (system_area); 1697 mrps_ptr = null (); 1698 end; 1699 1700 if mr_sort_ptr ^= null () then do; 1701 free mr_sort in (system_area); 1702 mr_sort_ptr = null (); 1703 end; 1704 1705 if trace_address ^= null () then call mail_system_$free_address (trace_address, (0)); 1706 1707 if comment_sender ^= null () then call mail_system_$free_address (comment_sender, (0)); 1708 1709 call cleanup_message_scan (); /* cleanup straight-forward data */ 1710 call lex_and_parse_epilogue ("1"b); 1711 1712 return; 1713 1714 end cleanup_message_parse_data; 1715 1716 /* Scan the complete text of a message: isolate the message header and body; locate and classify each header field in the 1717* message */ 1718 1719 scan_message_text: 1720 procedure (p_pto, p_ipo); 1721 1722 dcl 1 p_pto aligned like parse_text_options parameter; 1723 dcl 1 p_ipo aligned like internal_parse_options parameter; 1724 1725 dcl message_header character (message_header_lth) unaligned based (message_header_ptr); 1726 dcl message_header_lth fixed binary (21); 1727 dcl message_header_ptr pointer; 1728 1729 dcl message_body character (message_body_lth) unaligned based (message_body_ptr); 1730 dcl message_body_lth fixed binary (21); 1731 dcl message_body_ptr pointer; 1732 1733 dcl field_name character (field_name_lth) unaligned based (field_name_ptr); 1734 dcl field_name_lth fixed binary (21); /* current header field being examined */ 1735 dcl field_name_ptr pointer; 1736 1737 dcl (continuation_found, in_forwarding_info, in_comment_info) bit (1) aligned; 1738 1739 dcl (start, eol_idx, idx, idx2, field_name_start, field_value_start) fixed binary (21); 1740 1741 dcl (total_field_count, field_type) fixed binary; 1742 1743 1744 message_body_ptr, /* examine entire message initially */ 1745 message_header_ptr = representation_ptr; 1746 message_body_lth, message_header_lth = representation_lth; 1747 message_scan.header_offset = 0; 1748 1749 idx = verify (message_header, NL); /* strip leading newlines added by defective FTP mailers */ 1750 if idx ^= 0 then 1751 if idx ^= 1 then do; 1752 message_body_ptr, message_header_ptr = addcharno (message_body_ptr, (idx - 1)); 1753 message_body_lth, message_header_lth = message_header_lth - (idx - 1); 1754 end; 1755 else ; /* no leading newlines */ 1756 else go to NO_HEADER_FOUND_IN_MESSAGE; /* all newlines: no header */ 1757 1758 message_scan.header_offset = charno (message_header_ptr) - charno (representation_ptr); 1759 1760 idx = index (message_header, NLNL); /* search for header delimiter (double newline) */ 1761 if idx ^= 0 then /* seems to have a header: adjust length ... */ 1762 message_header_lth = idx; /* ... if is missing, assume messageless header */ 1763 1764 idx = index (message_header, NL); /* the header must have at least one newline in it */ 1765 if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE; 1766 1767 idx = index (substr (message_header, 1, idx), COLON); 1768 /* header must have colon on first line */ 1769 if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE; 1770 1771 1772 /* The message appears to have a header: tentatively set the location and size of the message body */ 1773 1774 message_body_ptr = addcharno (message_body_ptr, message_header_lth); 1775 message_body_lth = message_body_lth - message_header_lth; 1776 1777 if message_body_lth <= 0 then do; /* appears to be no body in the message, just a header */ 1778 message_scan.body_ptr = addr (NL); 1779 message_scan.body_lth = 0; 1780 end; 1781 1782 else do; /* something there: strip leading newlines */ 1783 idx = verify (message_body, NL); 1784 if (idx = 0) then message_body_lth = 0; /* nothing but blank lines */ 1785 else if (idx ^= 1) then do; /* some leading blank lines */ 1786 message_body_ptr = addcharno (message_body_ptr, (idx - 1)); 1787 message_body_lth = message_body_lth - (idx - 1); 1788 end; 1789 if (message_body_lth = 0) then do; /* bodyless message */ 1790 message_scan.body_ptr = addr (NL); 1791 message_scan.body_lth = 0; 1792 end; 1793 else do; /* really do have body */ 1794 message_scan.body_ptr = message_body_ptr; 1795 message_scan.body_lth = message_body_lth; 1796 end; 1797 end; 1798 1799 1800 /* Setup structures used to indicate results of the scan */ 1801 1802 message_scan.n_header_fields_allocated = /* can't be more fields than lines in the header */ 1803 count_lines_in_text (message_header_ptr, message_header_lth); 1804 1805 allocate header_field_list in (system_area) set (message_scan.header_field_list_ptr); 1806 header_field_list.n_fields = 0; /* nothing examined yet */ 1807 1808 allocate field_by_type_lists in (system_area) set (message_scan.field_by_type_lists_ptr); 1809 field_by_type_lists.types (*).n_fields = 0; 1810 1811 allocate forwarding_info_list in (system_area) set (message_scan.forwarding_info_list_ptr); 1812 forwarding_info_list.n_forwarding_infos = 0; 1813 1814 allocate comment_info_list in (system_area) set (message_scan.comment_info_list_ptr); 1815 comment_info_list.n_comment_infos = 0; 1816 1817 allocate user_field_list in (system_area) set (message_scan.user_field_list_ptr); 1818 user_field_list.n_user_fields = 0; 1819 1820 1821 /* Now examine the purported header: find each field and classify it */ 1822 1823 start = 1; 1824 1825 total_field_count = 0; /* no fields yet */ 1826 1827 in_forwarding_info = "0"b; /* not in the middle of a forwarding description */ 1828 in_comment_info = "0"b; /* ... ditto for comments */ 1829 1830 1831 do while (start < message_header_lth); 1832 1833 eol_idx = index (substr (message_header, start), NL); 1834 /* find the end of this line */ 1835 if eol_idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE; 1836 /* fields must end in newline */ 1837 1838 idx = index (substr (message_header, start, eol_idx), COLON); 1839 if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE; 1840 /* field name MUST be on first line */ 1841 1842 field_name_ptr = addcharno (message_header_ptr, (start - 1)); 1843 field_name_start = start; /* record where the field starts (for error messages) */ 1844 field_name_lth = idx - 1; /* initially everything up to the colon */ 1845 1846 idx2 = verify (field_name, HTSP); /* field name must start at left margin */ 1847 if idx2 ^= 1 then go to NO_HEADER_FOUND_IN_MESSAGE; 1848 1849 field_name_lth = length (rtrim (field_name, HTSP)); 1850 /* strip trailing whitespace from name */ 1851 1852 start = start + idx; /* skip to first character after the colon */ 1853 1854 idx = verify (substr (message_header, start), HTSP); 1855 if idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE; 1856 /* nothing after the colon (even a newline) */ 1857 1858 start = start + idx - 1; /* skip over the intervening whitespace */ 1859 field_value_start = start; /* and remember where it is */ 1860 1861 continuation_found = "1"b; /* look for continuation lines */ 1862 do while (continuation_found); 1863 eol_idx = index (substr (message_header, start), NL); 1864 if eol_idx = 0 then go to NO_HEADER_FOUND_IN_MESSAGE; 1865 start = start + eol_idx; /* skip to the next line */ 1866 if index (HTSP, substr (message_header, start, 1)) ^= 0 then 1867 continuation_found = "1"b; /* this line is a continuation of the current field */ 1868 else continuation_found = "0"b; /* a new field */ 1869 end; 1870 1871 header_field_list.n_fields, /* here's a new field */ 1872 field_idx = header_field_list.n_fields + 1; 1873 1874 header_field_list.fields (field_idx).field_value_ptr = 1875 addcharno (message_header_ptr, (field_value_start - 1)); 1876 /* where it starts ... */ 1877 header_field_list.fields (field_idx).field_value_lth = start - (field_value_start + 1); 1878 /* ... and how long excluding the trailing newline ... */ 1879 header_field_list.fields (field_idx).field_value_lth = length (rtrim (header_field_value, HTSP)); 1880 /* ... and trailing whitespace */ 1881 1882 header_field_list.fields (field_idx).complete_field_start = field_name_start; 1883 header_field_list.fields (field_idx).complete_field_lth = 1884 field_value_start - field_name_start + header_field_list.fields (field_idx).field_value_lth; 1885 /* record location/size of entire field for error reporting */ 1886 1887 call mlsys_field_id_mgr_$get_system_field_type (field_name, field_type, code); 1888 if code ^= 0 then do; /* field name is reserved for future expansion ... */ 1889 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 1890 header_field_list.fields (field_idx).complete_field_lth, ""); 1891 header_field_list.n_fields, field_idx = header_field_list.n_fields - 1; 1892 go to PROCESS_NEXT_FIELD; 1893 end; 1894 1895 1896 if field_type = USER_DEFINED_FIELD then do; /* unrecognized field name */ 1897 TREAT_AS_USER_DEFINED_FIELD: 1898 in_forwarding_info, in_comment_info = "0"b; 1899 /* force a new grouping */ 1900 user_field_list.n_user_fields, /* another one */ 1901 idx = user_field_list.n_user_fields + 1; 1902 user_field_list.user_fields (idx).field_value_idx = header_field_list.n_fields; 1903 call mail_system_$get_user_field_id ((field_name), user_field_list.user_fields (idx).field_id, (""), 1904 code); 1905 if (code ^= 0) & (code ^= error_table_$smallarg) then call message_parse_error_fatal (code); 1906 end; /* ... get_user_field_id shouldn't fail */ 1907 1908 else if (field_type > ORDINARY_FIELDS_BASE) & (field_type <= N_ORDINARY_FIELDS) then do; 1909 /* an ordinary field */ 1910 in_forwarding_info, in_comment_info = "0"b; 1911 field_by_type_lists.types (field_type).n_fields, idx = 1912 field_by_type_lists.types (field_type).n_fields + 1; 1913 field_by_type_lists.types (field_type).field_idxs (idx) = header_field_list.n_fields; 1914 end; 1915 1916 else if (field_type > REDISTRIBUTED_FIELDS_BASE) 1917 & (field_type <= (REDISTRIBUTED_FIELDS_BASE + N_ORDINARY_FIELDS)) then do; 1918 /* part of a forwarding description */ 1919 field_type = field_type - REDISTRIBUTED_FIELDS_BASE; 1920 if ^in_forwarding_info then call create_forwarding_info (); 1921 else if (forwarding_info.types (field_type).n_fields > 0) 1922 & ^MULTIPLE_FIELDS_PER_REDISTRIBUTION (field_type) then 1923 call create_forwarding_info (); 1924 else if forwarding_info.types (MESSAGE_ID_FIELD).n_fields > 0 then call create_forwarding_info (); 1925 in_forwarding_info = "1"b; /* ... in the middle of one now */ 1926 in_comment_info = "0"b; /* ... can't be doing this anymore */ 1927 forwarding_info.types (field_type).n_fields, idx = forwarding_info.types (field_type).n_fields + 1; 1928 forwarding_info.types (field_type).field_idxs (idx) = header_field_list.n_fields; 1929 end; /* ... set index of this field */ 1930 1931 else if (field_type > COMMENT_FIELDS_BASE) & (field_type <= (COMMENT_FIELDS_BASE + N_ORDINARY_FIELDS)) 1932 then do; /* part of a comment description */ 1933 field_type = field_type - COMMENT_FIELDS_BASE; 1934 if ^in_comment_info then call create_comment_info (); 1935 else if (comment_info.types (field_type).n_fields > 0) & ^MULTIPLE_FIELDS_PER_COMMENT (field_type) 1936 then 1937 call create_comment_info (); 1938 in_comment_info = "1"b; /* ... in the middle of one now */ 1939 in_forwarding_info = "0"b; /* ... can't be doing this anymore */ 1940 comment_info.types (field_type).n_fields, idx = comment_info.types (field_type).n_fields + 1; 1941 comment_info.types (field_type).field_idxs (idx) = header_field_list.n_fields; 1942 end; /* ... set index of this field */ 1943 1944 else go to TREAT_AS_USER_DEFINED_FIELD; /* shouldn't get here, of course */ 1945 1946 total_field_count = total_field_count + 1; /* another field taken care of */ 1947 1948 PROCESS_NEXT_FIELD: 1949 end; /* of scan loop */ 1950 1951 return; 1952 1953 1954 /* Control arives here if and only if a valid header is not found in the message */ 1955 1956 NO_HEADER_FOUND_IN_MESSAGE: 1957 call message_parse_error_fatal (mlsys_et_$no_message_header); 1958 1959 return; /* will never get here, but ... */ 1960 1961 1962 1963 /* Internal to scan_message_text: count the lines in a piece of text */ 1964 1965 count_lines_in_text: 1966 procedure (p_text_ptr, p_text_lth) returns (fixed binary (21)); 1967 1968 dcl the_text character (p_text_lth) unaligned based (p_text_ptr); 1969 dcl p_text_ptr pointer parameter; 1970 dcl p_text_lth fixed binary (21) parameter; 1971 1972 dcl (n_lines, used, idx) fixed binary (21); 1973 1974 n_lines, used = 0; 1975 1976 do while (used < p_text_lth); 1977 1978 begin; 1979 1980 dcl rest_of_text character (p_text_lth - used) unaligned defined (the_text) position (used + 1); 1981 1982 idx = index (rest_of_text, NL); 1983 if idx = 0 then idx = length (rest_of_text) + 1; 1984 1985 n_lines = n_lines + 1; 1986 used = used + idx; 1987 end; 1988 end; 1989 1990 return (n_lines); 1991 1992 end count_lines_in_text; 1993 1994 1995 1996 /* Internal to scan_message_text: start the description of a new forwarding operation */ 1997 1998 create_forwarding_info: 1999 procedure (); 2000 2001 forwarding_info_list.n_forwarding_infos = forwarding_info_list.n_forwarding_infos + 1; 2002 2003 allocate forwarding_info in (system_area) set (forwarding_info_ptr); 2004 forwarding_info_list.forwarding_info_ptrs (forwarding_info_list.n_forwarding_infos) = forwarding_info_ptr; 2005 2006 forwarding_info.types (*).n_fields = 0; 2007 2008 return; 2009 2010 end create_forwarding_info; 2011 2012 2013 2014 /* Internal to scan_message_text: start the description of a new commenting operation */ 2015 2016 create_comment_info: 2017 procedure (); 2018 2019 comment_info_list.n_comment_infos = comment_info_list.n_comment_infos + 1; 2020 2021 allocate comment_info in (system_area) set (comment_info_ptr); 2022 comment_info_list.comment_info_ptrs (comment_info_list.n_comment_infos) = comment_info_ptr; 2023 2024 comment_info.types (*).n_fields = 0; 2025 2026 return; 2027 2028 end create_comment_info; 2029 2030 end scan_message_text; 2031 2032 /* Cleanup the results of a message scan */ 2033 2034 cleanup_message_scan: 2035 procedure (); 2036 2037 dcl idx fixed binary; 2038 2039 if message_scan.header_field_list_ptr ^= null () then free header_field_list in (system_area); 2040 2041 if message_scan.field_by_type_lists_ptr ^= null () then free field_by_type_lists in (system_area); 2042 2043 if message_scan.forwarding_info_list_ptr ^= null () then do; 2044 do idx = 1 to forwarding_info_list.n_forwarding_infos; 2045 forwarding_info_ptr = forwarding_info_list.forwarding_info_ptrs (idx); 2046 free forwarding_info in (system_area); 2047 end; 2048 free forwarding_info_list in (system_area); 2049 end; 2050 2051 if message_scan.comment_info_list_ptr ^= null () then do; 2052 do idx = 1 to comment_info_list.n_comment_infos; 2053 comment_info_ptr = comment_info_list.comment_info_ptrs (idx); 2054 free comment_info in (system_area); 2055 end; 2056 free comment_info_list in (system_area); 2057 end; 2058 2059 if message_scan.user_field_list_ptr ^= null () then free user_field_list in (system_area); 2060 2061 message_scan.array_pointers = null (); /* don't try to free them again */ 2062 2063 return; 2064 2065 end cleanup_message_scan; 2066 2067 /* Report an error in the message parse: aborts the parse if required */ 2068 2069 message_parse_error: 2070 procedure (p_pto, p_code, p_text_start, p_text_lth, p_additional_info); 2071 2072 dcl 1 p_pto aligned like parse_text_options parameter; 2073 dcl p_code fixed binary (35) parameter; 2074 dcl (p_text_start, p_text_lth) fixed binary (21) parameter; 2075 dcl p_additional_info character (*) varying parameter; 2076 2077 dcl new_ptel_ptr pointer; 2078 dcl idx fixed binary; 2079 2080 if ^p_pto.list_errors then /* any error is fatal if caller doesn't want list or errors */ 2081 call message_parse_error_fatal (p_code); 2082 2083 message_parse_fails = "1"b; /* set global flag to force correct returned status code */ 2084 2085 if parse_text_error_list_ptr = null () then 2086 parse_text_error_list_n_errors = 1; 2087 else parse_text_error_list_n_errors = parse_text_error_list.n_errors + 1; 2088 2089 allocate parse_text_error_list in (user_area) set (new_ptel_ptr); 2090 2091 do idx = 1 to (parse_text_error_list_n_errors - 1); 2092 new_ptel_ptr -> parse_text_error_list.errors (idx) = parse_text_error_list.errors (idx); 2093 end; 2094 2095 if parse_text_error_list_ptr ^= null () then free parse_text_error_list in (user_area); 2096 parse_text_error_list_ptr = new_ptel_ptr; 2097 2098 idx = parse_text_error_list_n_errors; /* it's a shorter name ... */ 2099 2100 parse_text_error_list.errors (idx).text_start = p_text_start + message_scan.header_offset; 2101 parse_text_error_list.errors (idx).text_lth = p_text_lth; 2102 parse_text_error_list.errors (idx).code = p_code; 2103 parse_text_error_list.errors (idx).additional_info = p_additional_info; 2104 2105 return; 2106 2107 end message_parse_error; 2108 2109 /* Handler for fatal errors during the parsing of a message */ 2110 2111 message_parse_error_fatal: 2112 procedure (p_code); 2113 2114 dcl p_code fixed binary (35) parameter; 2115 2116 call cleanup_message_parse_data (); /* get rid of everything we've created */ 2117 2118 if message_ptr ^= null () then call free_message (message_ptr, (0)); 2119 2120 if parse_text_error_list_ptr ^= null () then /* release the error description we setup */ 2121 free parse_text_error_list in (user_area); 2122 2123 if parse_text_options.list_errors then do; /* caller wants to see the actual reason */ 2124 parse_text_error_list_n_errors = 1; 2125 allocate parse_text_error_list in (user_area) set (parse_text_error_list_ptr); 2126 parse_text_error_list.errors (1).text_start = 1; 2127 parse_text_error_list.errors (1).text_lth = 0; 2128 parse_text_error_list.errors (1).code = p_code; 2129 parse_text_error_list.errors (1).additional_info = ""; 2130 P_parse_text_error_list_ptr = parse_text_error_list_ptr; 2131 end; 2132 2133 P_message_ptr = null (); /* informs the caller that error too severe to bypass */ 2134 P_code = mlsys_et_$text_parse_failed; /* use standard global error code */ 2135 2136 go to RETURN_FROM_MESSAGE_PARSE_AFTER_FAILURE; 2137 2138 end message_parse_error_fatal; 2139 2140 2141 RETURN_FROM_MESSAGE_PARSE_AFTER_FAILURE: 2142 return; 2143 2144 /* Mark all fields of a given type as being reserved for in-mailbox messages only (only called from main procedure) */ 2145 2146 mark_as_in_mailbox_field: 2147 procedure (p_field_list_ptr); 2148 2149 dcl p_field_list_ptr pointer parameter; 2150 2151 dcl 1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types; 2152 dcl idx fixed binary; 2153 2154 do idx = 1 to field_list.n_fields; 2155 field_idx = field_list.field_idxs (idx); 2156 call message_parse_error (parse_text_options, mlsys_et_$in_mailbox_only_field, 2157 header_field_list.fields (field_idx).complete_field_start, 2158 header_field_list.fields (field_idx).complete_field_lth, ""); 2159 end; 2160 2161 return; 2162 2163 end mark_as_in_mailbox_field; 2164 2165 2166 2167 /* Find the index of the first field in a given set of fields (redistributions/comments) for possible error reporting */ 2168 2169 find_first_field_in_list: 2170 procedure (p_field_lists_ptr, p_first_field_idx); 2171 2172 dcl p_field_lists_ptr pointer parameter; 2173 dcl p_first_field_idx fixed binary parameter; 2174 2175 dcl 1 field_lists aligned based (p_field_lists_ptr) like field_by_type_lists; 2176 dcl (idx, jdx) fixed binary; 2177 2178 p_first_field_idx = message_scan.n_header_fields_allocated + 1; 2179 2180 do idx = 1 to N_ORDINARY_FIELDS; 2181 do jdx = 1 to field_lists.types (idx).n_fields; 2182 p_first_field_idx = min (p_first_field_idx, field_lists.types (idx).field_idxs (jdx)); 2183 end; 2184 end; 2185 2186 return; 2187 2188 end find_first_field_in_list; 2189 2190 /* Set the implicit route for all the addresses in the given list */ 2191 2192 set_implicit_route: 2193 procedure (p_address_list_ptr, p_implicit_route); 2194 2195 dcl p_address_list_ptr pointer parameter; 2196 dcl p_implicit_route pointer parameter; 2197 2198 dcl idx fixed binary; 2199 2200 do idx = 1 to p_address_list_ptr -> address_list.n_addresses; 2201 call set_address_implicit_route (p_address_list_ptr -> address_list.addresses (idx), p_implicit_route, (0)) 2202 ; 2203 end; 2204 2205 return; 2206 2207 end set_implicit_route; 2208 2209 2210 2211 /* Set the message date/time created and Message-ID directly as we are in the mail system ring: used only by the 2212* parse_im_message_text entrypoint (as the appropriate "primitives") */ 2213 2214 set_date_time_created_directly: 2215 procedure (p_message_ptr, p_date_time_created, p_code); 2216 2217 dcl p_message_ptr pointer parameter; 2218 dcl p_date_time_created fixed binary (71) parameter; 2219 dcl p_code fixed binary (35) parameter; 2220 2221 message.date_time_created = p_date_time_created; 2222 p_code = 0; 2223 2224 return; 2225 2226 end set_date_time_created_directly; 2227 2228 2229 set_message_id_directly: 2230 procedure (p_message_ptr, p_message_id, p_code); 2231 2232 dcl p_message_ptr pointer parameter; 2233 dcl p_message_id bit (72) aligned parameter; 2234 dcl p_code fixed binary (35) parameter; 2235 2236 message.message_id = p_message_id; 2237 p_code = 0; 2238 2239 return; 2240 2241 end set_message_id_directly; 2242 2243 /* Prepare a group of text fields for inclusion into the message as a single line field */ 2244 2245 prepare_single_line_field: 2246 procedure (p_tf, p_field_list_ptr); 2247 2248 dcl 1 p_tf aligned parameter like message_text_field; 2249 dcl p_field_list_ptr pointer parameter; 2250 2251 dcl 1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types; 2252 2253 dcl total_text character (total_text_lth) unaligned based (total_text_ptr); 2254 dcl total_text_ptr pointer; 2255 dcl (total_text_lth, total_text_used) fixed binary (21); 2256 2257 dcl idx fixed binary; 2258 2259 2260 p_tf.multiline_text = "0"b; /* just to be sure */ 2261 2262 if field_list.n_fields = 0 then do; /* nothing there */ 2263 p_tf.text_ptr = null (); 2264 p_tf.text_lth = 0; 2265 end; 2266 2267 else if field_list.n_fields = 1 then do; /* one field: return it directly */ 2268 field_idx = field_list.field_idxs (1); 2269 p_tf.text_ptr = addr (header_field_value); 2270 p_tf.text_lth = length (header_field_value); 2271 end; 2272 2273 else do; /* multiple fields: merge them */ 2274 total_text_lth = -1; /* ... following loop computes a value that's one off */ 2275 do idx = 1 to field_list.n_fields; 2276 field_idx = field_list.field_idxs (idx); 2277 total_text_lth = total_text_lth + length (header_field_value) + 1; 2278 end; 2279 allocate total_text in (system_area) set (total_text_ptr); 2280 total_text_used = 0; 2281 do idx = 1 to field_list.n_fields; 2282 if idx > 1 then do; /* ... separate them by a single space */ 2283 substr (total_text, (total_text_used + 1), 1) = SP; 2284 total_text_used = total_text_used + 1; 2285 end; 2286 field_idx = field_list.field_idxs (idx); 2287 substr (total_text, (total_text_used + 1), length (header_field_value)) = header_field_value; 2288 total_text_used = total_text_used + length (header_field_value); 2289 end; 2290 p_tf.text_ptr = total_text_ptr; 2291 p_tf.text_lth = total_text_lth; 2292 end; 2293 2294 return; 2295 2296 end prepare_single_line_field; 2297 2298 /* Prepare one or more text fields for inclusion in the message as a multiline field */ 2299 2300 prepare_multiline_field: 2301 procedure () options (non_quick); 2302 2303 return; /* not an entrypoint */ 2304 2305 dcl p_fieldname_lth fixed binary parameter; 2306 dcl 1 p_tf aligned parameter like message_text_field; 2307 dcl p_field_value character (*) parameter; 2308 dcl p_field_list_ptr pointer parameter; 2309 2310 dcl 1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types; 2311 2312 dcl total_text character (total_text_lth) unaligned based (total_text_ptr); 2313 dcl total_text_ptr pointer; 2314 dcl (total_text_lth, total_text_used) fixed binary (21); 2315 2316 dcl work_string character (work_string_lth) unaligned based (work_string_ptr); 2317 dcl work_string_ptr pointer; 2318 dcl (work_string_lth, work_string_used) fixed binary (21); 2319 2320 dcl previous_text character (p_tf.text_lth) unaligned based (p_tf.text_ptr); 2321 2322 dcl idx fixed binary; 2323 2324 dcl STACK_EXTENSION fixed binary (18) static options (constant) initial (128); 2325 2326 dcl FIELDNAME_SUFFIX character (3) static options (constant) initial (": "); 2327 dcl STANDARD_MULTILINE_INDENTATION fixed binary static options (constant) initial (10); 2328 dcl CONTINUATION_INDICATOR character (2) static options (constant) initial ("--"); 2329 2330 2331 prepare_multiline_field_from_text: /* prepare a single field */ 2332 entry (p_fieldname_lth, p_tf, p_field_value); 2333 2334 call cu_$grow_stack_frame (STACK_EXTENSION, work_string_ptr, (0)); 2335 work_string_lth = 4 * STACK_EXTENSION; 2336 work_string_used = 0; 2337 2338 call prepare_single_field_for_multiline (p_field_value); 2339 2340 go to PREPARE_MULTILINE_FIELD_COMMON; 2341 2342 2343 prepare_multiline_field_from_list: /* prepare a list of fields */ 2344 entry (p_fieldname_lth, p_tf, p_field_list_ptr); 2345 2346 call cu_$grow_stack_frame (STACK_EXTENSION, work_string_ptr, (0)); 2347 work_string_lth = 4 * STACK_EXTENSION; 2348 work_string_used = 0; 2349 2350 do idx = 1 to field_list.n_fields; 2351 field_idx = field_list.field_idxs (idx); 2352 call prepare_single_field_for_multiline (header_field_value); 2353 end; 2354 2355 go to PREPARE_MULTILINE_FIELD_COMMON; 2356 2357 2358 /* Input fields have been properly prepared: combine them with any prior text and return the new text */ 2359 2360 PREPARE_MULTILINE_FIELD_COMMON: 2361 p_tf.multiline_text = "1"b; /* just in case */ 2362 if p_tf.text_ptr = null () then p_tf.text_lth = 0; 2363 2364 if work_string_used = 0 then return; /* the input fields are empty */ 2365 2366 total_text_lth = p_tf.text_lth + work_string_used - 1; 2367 if p_tf.text_lth > 0 then total_text_lth = total_text_lth + 1; 2368 2369 allocate total_text in (system_area) set (total_text_ptr); 2370 2371 if p_tf.text_lth > 0 then do; /* copy prior text */ 2372 substr (total_text, 1, length (previous_text)) = previous_text; 2373 substr (total_text, (length (previous_text) + 1), 1) = NL; 2374 total_text_used = length (previous_text) + 1; 2375 free previous_text in (system_area); 2376 end; 2377 else total_text_used = 0; 2378 2379 substr (total_text, (total_text_used + 1), (work_string_used - 1)) = 2380 substr (work_string, 1, (work_string_used - 1)); 2381 /* all except the trailing new line */ 2382 2383 p_tf.text_ptr = addr (total_text); 2384 p_tf.text_lth = length (total_text); 2385 2386 return; 2387 2388 2389 2390 /* Internal to prepare_multiline_field: processes a single field. All leading whitespace before the indent column is 2391* removed; any line which has "--" in the last two columns before the indent column is made a blank line */ 2392 2393 prepare_single_field_for_multiline: 2394 procedure (p_text) /* options (quick) */; 2395 2396 dcl p_text character (*) parameter; 2397 dcl (text_column, text_used, line_lth, start_of_text, column, used) fixed binary (21); 2398 2399 if verify (before (p_text, NL), HTSP) = 0 then do; 2400 text_column = STANDARD_MULTILINE_INDENTATION + 1; 2401 text_used = index (p_text, NL); /* special case if first line blank: it's indented 10 */ 2402 end; 2403 else do; 2404 text_column = p_fieldname_lth + length (FIELDNAME_SUFFIX) + 1; 2405 text_used = 0; 2406 end; 2407 2408 do while (text_used < length (p_text)); 2409 begin; 2410 dcl rest_of_text character (length (p_text) - text_used) unaligned defined (p_text) position (text_used + 1); 2411 line_lth = index (rest_of_text, NL) - 1; 2412 if line_lth = -1 then /* last line */ 2413 line_lth = length (rest_of_text); 2414 end; 2415 2416 if line_lth > 0 then 2417 begin; 2418 dcl line character (line_lth) unaligned defined (p_text) position (text_used + 1); 2419 start_of_text = verify (line, HTSP); 2420 if start_of_text = 0 then /* it's blank? */ 2421 start_of_text = line_lth + 1; 2422 2423 begin; 2424 dcl whitespace character (start_of_text - 1) unaligned defined (p_text) position (text_used + 1); 2425 column = 1; 2426 used = 0; 2427 do while ((used < length (whitespace)) & (column < text_column)); 2428 used = used + 1; 2429 if substr (whitespace, used, 1) = SP then column = column + 1; 2430 else if mod (column, 10) = 0 then column = column + 1; 2431 else column = column + 11 - mod (column, 10); 2432 end; 2433 if (column < (text_column - 1)) & (start_of_text < line_lth) then 2434 if substr (line, start_of_text, 2) = CONTINUATION_INDICATOR then 2435 if verify (substr (line, (start_of_text + 2)), HTSP) = 0 then 2436 go to LINE_IS_ACTUALLY_BLANK; 2437 if used < length (whitespace) then 2438 start_of_text = start_of_text - (length (whitespace) - used); 2439 end; 2440 2441 begin; 2442 dcl text character (line_lth - start_of_text + 1) unaligned defined (p_text) position (text_used + start_of_text); 2443 call add_to_work_string (addr (text), length (text)); 2444 end; 2445 end; 2446 2447 LINE_IS_ACTUALLY_BLANK: 2448 call add_to_work_string (addr (NL), 1); 2449 2450 text_used = text_used + line_lth + 1; 2451 end; 2452 2453 return; 2454 2455 2456 2457 /* Internal to prepare_single_field_for_multiline: adds a piece of text to the output buffer */ 2458 2459 add_to_work_string: 2460 procedure (p_text_ptr, p_text_lth) /* options (quick) */; 2461 2462 dcl p_text_ptr pointer parameter; 2463 dcl p_text_lth fixed binary (21) parameter; 2464 2465 dcl p_text character (p_text_lth) unaligned based (p_text_ptr); 2466 2467 do while (work_string_lth < (work_string_used + p_text_lth)); 2468 call cu_$grow_stack_frame (STACK_EXTENSION, (null ()), (0)); 2469 work_string_lth = work_string_lth + 4 * STACK_EXTENSION; 2470 end; 2471 2472 substr (work_string, (work_string_used + 1), p_text_lth) = p_text; 2473 2474 work_string_used = work_string_used + p_text_lth; 2475 2476 return; 2477 2478 end add_to_work_string; 2479 2480 end prepare_single_field_for_multiline; 2481 2482 end prepare_multiline_field; 2483 2484 /* Parse a message/redistribution envelope: This entrypoint also parses the Date and From fields of the 2485* message/redistribution as they may be needed to supply defaults for the envelope and the message/redistribution ID */ 2486 2487 parse_envelope: 2488 procedure (p_pto, p_ipo, p_is_redistribution, p_field_lists_ptr, p_envelope_ptr, p_date_time_created, p_from) 2489 /* options (quick) */; 2490 2491 dcl 1 p_pto aligned like parse_text_options parameter; 2492 dcl 1 p_ipo aligned like internal_parse_options parameter; 2493 dcl p_is_redistribution bit (1) aligned parameter; 2494 dcl (p_field_lists_ptr, p_envelope_ptr, p_from) pointer parameter; 2495 dcl p_date_time_created fixed binary (71) parameter; 2496 2497 dcl 1 field_lists aligned like field_by_type_lists based (p_field_lists_ptr); 2498 dcl 1 envelope aligned like message_envelope based (p_envelope_ptr); 2499 2500 dcl 1 local_pto aligned like parse_text_options; 2501 dcl additional_info character (128) varying; 2502 dcl saved_default_system character (256) varying; 2503 dcl saved_default_system_is_local bit (1) aligned; 2504 dcl address_type fixed binary; 2505 dcl idx fixed binary; 2506 2507 2508 p_date_time_created, envelope.date_time_mailed, envelope.date_time_delivered = 0; 2509 envelope.sender, envelope.trace, envelope.delivered_by, envelope.acknowledge_to = null (); 2510 2511 if p_is_redistribution then 2512 additional_info = "The redistribution which starts with:"; 2513 else additional_info = "The message which starts with:"; 2514 2515 2516 /* First parse the Date, Posted-Date, and Delivery-Date fields: there can be at most one of each of these fields and all 2517* of them must parse. If the Posted-Date field is missing, it is set to the value of the Date field; if the 2518* Delivery-Date field is missing, it is set to the value of the Posted-Date field */ 2519 2520 if (field_lists.types (DATE_FIELD).n_fields = 0) & (field_lists.types (POSTED_DATE_FIELD).n_fields = 0) 2521 & (field_lists.types (DELIVERY_DATE_FIELD).n_fields = 0) then 2522 call message_parse_error (p_pto, mlsys_et_$cant_determine_dtc, 2523 header_field_list.fields (first_field_idx).complete_field_start, 2524 header_field_list.fields (first_field_idx).complete_field_lth, additional_info); 2525 2526 if field_lists.types (DATE_FIELD).n_fields = 1 then do; 2527 field_idx = field_lists.types (DATE_FIELD).field_idxs (1); 2528 call parse_date_time_text (p_pto, p_ipo, header_field_value, p_date_time_created, code); 2529 if code ^= 0 then 2530 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 2531 header_field_list.fields (field_idx).complete_field_lth, ""); 2532 end; 2533 else if field_lists.types (DATE_FIELD).n_fields > 1 then do; 2534 do idx = 1 to field_lists.types (DATE_FIELD).n_fields; 2535 field_idx = field_lists.types (DATE_FIELD).field_idxs (idx); 2536 call message_parse_error (p_pto, mlsys_et_$extra_restricted_field, 2537 header_field_list.fields (field_idx).complete_field_start, 2538 header_field_list.fields (field_idx).complete_field_lth, ""); 2539 end; 2540 end; 2541 2542 if field_lists.types (POSTED_DATE_FIELD).n_fields = 1 then do; 2543 field_idx = field_lists.types (POSTED_DATE_FIELD).field_idxs (1); 2544 call parse_date_time_text (p_pto, p_ipo, header_field_value, envelope.date_time_mailed, code); 2545 if code ^= 0 then 2546 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 2547 header_field_list.fields (field_idx).complete_field_lth, ""); 2548 end; 2549 else if field_lists.types (POSTED_DATE_FIELD).n_fields > 1 then do; 2550 do idx = 1 to field_lists.types (POSTED_DATE_FIELD).n_fields; 2551 field_idx = field_lists.types (POSTED_DATE_FIELD).field_idxs (idx); 2552 call message_parse_error (p_pto, mlsys_et_$extra_restricted_field, 2553 header_field_list.fields (field_idx).complete_field_start, 2554 header_field_list.fields (field_idx).complete_field_lth, ""); 2555 end; 2556 end; 2557 2558 if field_lists.types (DELIVERY_DATE_FIELD).n_fields = 1 then do; 2559 field_idx = field_lists.types (DELIVERY_DATE_FIELD).field_idxs (1); 2560 call parse_date_time_text (p_pto, p_ipo, header_field_value, envelope.date_time_delivered, code); 2561 if code ^= 0 then 2562 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 2563 header_field_list.fields (field_idx).complete_field_lth, ""); 2564 end; 2565 else if field_lists.types (DELIVERY_DATE_FIELD).n_fields > 1 then do; 2566 do idx = 1 to field_lists.types (DELIVERY_DATE_FIELD).n_fields; 2567 field_idx = field_lists.types (DELIVERY_DATE_FIELD).field_idxs (idx); 2568 call message_parse_error (p_pto, mlsys_et_$extra_restricted_field, 2569 header_field_list.fields (field_idx).complete_field_start, 2570 header_field_list.fields (field_idx).complete_field_lth, ""); 2571 end; 2572 end; 2573 2574 if p_date_time_created = 0 then /* Date really should be there but ... */ 2575 if envelope.date_time_mailed ^= 0 then /* ... so supply one */ 2576 p_date_time_created = envelope.date_time_mailed; 2577 else p_date_time_created = envelope.date_time_delivered; 2578 2579 if envelope.date_time_mailed = 0 then /* Posted-Date defaults to Date */ 2580 envelope.date_time_mailed = p_date_time_created; 2581 2582 if envelope.date_time_delivered = 0 then /* Delivery-Date defaults to Posted-Date */ 2583 envelope.date_time_delivered = envelope.date_time_mailed; 2584 2585 2586 /* Parse the From and Sender fields: both must contain only valid addresses; in addition, there may only be one Sender 2587* field and it is allowed to contain only a single address. After parsing, determine the default system to be used to 2588* parse other addresses in the header or redistribution */ 2589 2590 p_ipo.default_system_name = mlsys_nit_interface_$get_local_system_name (); 2591 p_ipo.default_system_is_local = "1"b; /* local system is the default default system */ 2592 2593 string (local_pto.flags) = ""b; /* requires it to parse properly */ 2594 2595 if field_lists.types (SENDER_FIELD).n_fields = 1 then do; 2596 field_idx = field_lists.types (SENDER_FIELD).field_idxs (1); 2597 call parse_address_text_internal (local_pto, p_ipo, header_field_value, envelope.sender, code); 2598 if code ^= 0 then 2599 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 2600 header_field_list.fields (field_idx).complete_field_lth, ""); 2601 end; 2602 else if field_lists.types (SENDER_FIELD).n_fields > 1 then do; 2603 do idx = 1 to field_lists.types (SENDER_FIELD).n_fields; 2604 field_idx = field_lists.types (SENDER_FIELD).field_idxs (idx); 2605 call message_parse_error (p_pto, mlsys_et_$extra_restricted_field, 2606 header_field_list.fields (field_idx).complete_field_start, 2607 header_field_list.fields (field_idx).complete_field_lth, ""); 2608 end; 2609 end; 2610 2611 if envelope.sender ^= null () then do; /* we have a Sender: extract the default system */ 2612 call mail_system_$get_address_type (envelope.sender, address_type, (0)); 2613 if address_type = FOREIGN_ADDRESS then do; /* ... only if it's foreign, however */ 2614 call mail_system_$get_address_system (envelope.sender, p_ipo.default_system_name, (0)); 2615 p_ipo.default_system_is_local = mlsys_nit_interface_$is_local_system (p_ipo.default_system_name); 2616 end; 2617 end; 2618 2619 if p_is_redistribution then 2620 full_fieldname = REDISTRIBUTED_PREFIX || FROM_FIELDNAME; 2621 else full_fieldname = FROM_FIELDNAME; 2622 2623 call parse_address_list_field (p_pto, p_ipo, full_fieldname, addr (field_lists.types (FROM_FIELD)), p_from); 2624 2625 if envelope.sender = null () then /* no Sender: use From field to get default system */ 2626 if p_from -> address_list.n_addresses = 1 then do; 2627 call mail_system_$get_address_type (p_from -> address_list.addresses (1), address_type, (0)); 2628 if address_type = FOREIGN_ADDRESS then do; 2629 call mail_system_$get_address_system (p_from -> address_list.addresses (1), 2630 p_ipo.default_system_name, (0)); 2631 p_ipo.default_system_is_local = mlsys_nit_interface_$is_local_system (p_ipo.default_system_name); 2632 end; 2633 end; 2634 2635 else do; /* no Sender and the From field has multiple addresses */ 2636 call message_parse_error (p_pto, mlsys_et_$cant_determine_sender, 2637 header_field_list.fields (first_field_idx).complete_field_start, 2638 header_field_list.fields (first_field_idx).complete_field_lth, additional_info); 2639 end; /* ... so continue to claim local system is the default */ 2640 2641 2642 /* Parse the Delivery-By and Acknowledge-To fields (if present): each must appear only once and contain exactly one valid 2643* address */ 2644 2645 saved_default_system = p_ipo.default_system_name; 2646 saved_default_system_is_local = p_ipo.default_system_is_local; 2647 p_ipo.default_system_name = mlsys_nit_interface_$get_local_system_name (); 2648 p_ipo.default_system_is_local = "1"b; /* Delivery-By must be an absolute address */ 2649 2650 if field_lists.types (DELIVERY_BY_FIELD).n_fields = 1 then do; 2651 field_idx = field_lists.types (DELIVERY_BY_FIELD).field_idxs (1); 2652 call parse_address_text_internal (local_pto, p_ipo, header_field_value, envelope.delivered_by, code); 2653 if code ^= 0 then 2654 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 2655 header_field_list.fields (field_idx).complete_field_lth, ""); 2656 end; 2657 else if field_lists.types (DELIVERY_BY_FIELD).n_fields > 1 then do; 2658 do idx = 1 to field_lists.types (DELIVERY_BY_FIELD).n_fields; 2659 field_idx = field_lists.types (DELIVERY_BY_FIELD).field_idxs (idx); 2660 call message_parse_error (p_pto, mlsys_et_$extra_restricted_field, 2661 header_field_list.fields (field_idx).complete_field_start, 2662 header_field_list.fields (field_idx).complete_field_lth, ""); 2663 end; 2664 end; 2665 2666 p_ipo.default_system_name = saved_default_system; 2667 p_ipo.default_system_is_local = saved_default_system_is_local; 2668 2669 if p_ipo.requests_acknowledgement then /* don't both to look unless it's going to be acknowledged */ 2670 if field_lists.types (ACKNOWLEDGE_TO_FIELD).n_fields = 1 then do; 2671 field_idx = field_lists.types (ACKNOWLEDGE_TO_FIELD).field_idxs (1); 2672 call parse_address_text_internal (local_pto, p_ipo, header_field_value, envelope.acknowledge_to, code) 2673 ; 2674 if code ^= 0 then 2675 call message_parse_error (p_pto, code, header_field_list.fields (field_idx).complete_field_start, 2676 header_field_list.fields (field_idx).complete_field_lth, ""); 2677 end; 2678 else if field_lists.types (ACKNOWLEDGE_TO_FIELD).n_fields > 1 then do; 2679 do idx = 1 to field_lists.types (ACKNOWLEDGE_TO_FIELD).n_fields; 2680 field_idx = field_lists.types (ACKNOWLEDGE_TO_FIELD).field_idxs (idx); 2681 call message_parse_error (p_pto, mlsys_et_$extra_restricted_field, 2682 header_field_list.fields (field_idx).complete_field_start, 2683 header_field_list.fields (field_idx).complete_field_lth, ""); 2684 end; 2685 end; 2686 2687 2688 /* Supply a default From field (equal to the Sender) and eliminate redundant Sender and/or Delivery-By addresses */ 2689 2690 if p_from -> address_list.n_addresses = 0 then do;/* no From field supplied */ 2691 call add_address (p_from, envelope.sender, ADDRESS_LIST_VERSION_2, code); 2692 if code ^= 0 then call message_parse_error_fatal (code); 2693 envelope.sender = null (); /* ... let's not be redundant */ 2694 end; 2695 2696 if p_from -> address_list.n_addresses = 1 then do;/* try to eliminate redundant Sender/Delivery-By */ 2697 if envelope.sender ^= null () then 2698 if mail_system_$compare_addresses (p_from -> address_list.addresses (1), envelope.sender, (0)) then 2699 call mail_system_$free_address (envelope.sender, (0)); 2700 if envelope.delivered_by ^= null () then 2701 if mail_system_$compare_addresses (p_from -> address_list.addresses (1), envelope.delivered_by, (0)) 2702 then 2703 call mail_system_$free_address (envelope.delivered_by, (0)); 2704 end; /* ... OK to free as parser never reuses addresses */ 2705 2706 if envelope.sender ^= null () then /* check for redundant Delivery-By */ 2707 if envelope.delivered_by ^= null () then 2708 if mail_system_$compare_addresses (envelope.sender, envelope.delivered_by, (0)) then 2709 call mail_system_$free_address (envelope.delivered_by, (0)); 2710 2711 2712 /* Finally, parse the message trace if present */ 2713 2714 if (field_lists.types (ROUTE_FIELD).n_fields > 0) | (field_lists.types (RELAYED_FIELD).n_fields > 0) then 2715 call parse_trace (); 2716 2717 return; 2718 2719 /* Internal to parse_envelope: parses the fields in a message trace; any errors in a message trace are considered 2720* non-fatal and the information in the trace is thrown away */ 2721 2722 parse_trace: 2723 procedure () /* options (quick) */; 2724 2725 dcl 1 current_relay aligned based (current_relay_ptr) like message_trace.relays; 2726 dcl current_relay_ptr pointer; 2727 2728 dcl 1 local_ipo aligned like internal_parse_options; 2729 2730 dcl the_route_ptr pointer; 2731 dcl address_system character (256) varying; 2732 dcl (start_of_id_string, end_of_id_string, bracket_level, message_id_string_lth, date_time_string_start) fixed 2733 binary (21); 2734 dcl (relay_idx, idx) fixed binary; 2735 2736 2737 message_trace_n_relays = max (field_lists.types (RELAYED_FIELD).n_fields, 1); 2738 /* PL/I abhors a vacuum */ 2739 2740 allocate message_trace in (system_area) set (message_trace_ptr); 2741 2742 message_trace.version = MESSAGE_TRACE_VERSION_2; 2743 message_trace.implicit_route = null (); 2744 message_trace.relays (*).date_time_relayed = 0; 2745 message_trace.relays (*).sending_host = ""; 2746 message_trace.relays (*).receiving_host = ""; 2747 message_trace.relays (*).communications_media = ""; 2748 message_trace.relays (*).communications_protocol = ""; 2749 message_trace.relays (*).mail_protocol = ""; 2750 message_trace.relays (*).relay_id = ""b; 2751 message_trace.relays (*).relay_recipient = null (); 2752 2753 envelope.trace = message_trace_ptr; /* cleanup handler will now work OK */ 2754 2755 2756 /* Find the route by which this message/redistribution arrived at this system by parsing the Route field: If there are 2757* multiple Route fields, all but the first are ignored as many systems add extraneous Route fields during transmission */ 2758 2759 trace_address = null (); /* for cleanup handler */ 2760 2761 if field_lists.types (ROUTE_FIELD).n_fields ^= 0 then do; 2762 2763 field_idx = field_lists.types (ROUTE_FIELD).field_idxs (1); 2764 2765 call lex_and_parse_prologue (header_field_value, "1"b, "0"b); 2766 /* no cleanup handler here: caller's set one up already */ 2767 2768 call lex_address (p_pto, p_ipo, code); /* convert into tokens */ 2769 if code ^= 0 then call bypass_implicit_route (code, "1"b); 2770 2771 token_idx = 0; /* start at the first non-comment token */ 2772 call next_real_token (); 2773 2774 if current.type = LEFTBRACKET_TOKEN then do; 2775 /*** RFC822 style route -- Return-Path: <@HOST,@HOST,...:STRING@HOST> */ 2776 call parse_address (p_pto, p_ipo, (token_idx - 1), trace_address, code); 2777 call lex_and_parse_epilogue ("1"b);/* ... won't need the token list any longer ... */ 2778 call cu_$shrink_stack_frame (stack_extension_ptr, (0)); 2779 if code ^= 0 then call bypass_implicit_route (code, "1"b); 2780 call mail_system_$get_address_route (trace_address, ADDRESS_ROUTE_VERSION_1, the_route_ptr, code) 2781 ; 2782 if code ^= 0 then call bypass_implicit_route (code, "0"b); 2783 call mail_system_$get_address_system (trace_address, address_system, code); 2784 if code ^= 0 then call bypass_implicit_route (code, "0"b); 2785 address_route_n_relays = the_route_ptr -> address_route.n_relays + 1; 2786 allocate address_route in (system_area) set (address_route_ptr); 2787 message_trace.implicit_route = address_route_ptr; 2788 address_route.version = ADDRESS_ROUTE_VERSION_1; 2789 do idx = 1 to address_route.n_relays - 1; 2790 address_route.relays (idx) = the_route_ptr -> address_route.relays (idx); 2791 end; 2792 address_route.relays (address_route.n_relays) = address_system; 2793 call mail_system_$free_address (trace_address, (0)); 2794 end; 2795 2796 else if current.type = AT_TOKEN then do; 2797 /*** Multics style route: [via RelayN ...] via Relay1 */ 2798 address_route_n_relays = 0; 2799 do while (current.type = AT_TOKEN); 2800 address_route_n_relays = address_route_n_relays + 1; 2801 call next_real_token (); /* ... to the system name */ 2802 if current.type ^= WORD_TOKEN then 2803 call bypass_implicit_route (mlsys_et_$missing_host_name, "1"b); 2804 host_indeces (address_route_n_relays) = token_idx; 2805 call next_real_token (); /* ... to the next "via" or the end of the string */ 2806 end; 2807 if current.type ^= END_OF_TEXT_TOKEN then 2808 call bypass_implicit_route (mlsys_et_$text_follows_route, "1"b); 2809 allocate address_route in (system_area) set (address_route_ptr); 2810 message_trace.implicit_route = address_route_ptr; 2811 address_route.version = ADDRESS_ROUTE_VERSION_1; 2812 do idx = 1 to address_route_n_relays; 2813 call make_token_current (host_indeces (idx)); 2814 address_route.relays (address_route_n_relays - idx + 1) = current_token; 2815 end; /* ... the printed representation is backward */ 2816 call lex_and_parse_epilogue ("1"b); 2817 call cu_$shrink_stack_frame (stack_extension_ptr, (0)); 2818 end; 2819 2820 else call bypass_implicit_route (mlsys_et_$invalid_route_field_syntax, "1"b); 2821 end; 2822 2823 2824 /* Determine the set of relay operations which took place to get the message here by parsing the Relayed fields */ 2825 2826 BYPASS_IMPLICIT_ROUTE: 2827 relay_idx = 1; /* in case we have to bypass some fields */ 2828 2829 do idx = 1 to field_lists.types (RELAYED_FIELD).n_fields; 2830 2831 field_idx = field_lists.types (RELAYED_FIELD).field_idxs (idx); 2832 current_relay_ptr = addr (message_trace.relays (relay_idx)); 2833 2834 call lex_and_parse_prologue (header_field_value, "1"b, "0"b); 2835 call lex_address (p_pto, p_ipo, code); 2836 if code ^= 0 then call bypass_relay_operation (code, "1"b); 2837 2838 token_idx = 0; /* start at the beginning */ 2839 call next_real_token (); 2840 2841 do while (current.type ^= SEMICOLON_TOKEN); 2842 if current.type = WORD_TOKEN then 2843 if translate (current_token, UPPERCASE, LOWERCASE) = "FROM" then do; 2844 call next_real_token (); 2845 if current.type = WORD_TOKEN then 2846 current_relay.sending_host = current_token; 2847 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2848 end; 2849 else if (translate (current_token, UPPERCASE, LOWERCASE) = "BY") 2850 | (translate (current_token, UPPERCASE, LOWERCASE) = "TO") then do; 2851 call next_real_token (); 2852 if current.type = WORD_TOKEN then 2853 current_relay.receiving_host = current_token; 2854 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2855 end; 2856 else if translate (current_token, UPPERCASE, LOWERCASE) = "USING" then do; 2857 call next_real_token (); 2858 if current.type = WORD_TOKEN then 2859 current_relay.mail_protocol = current_token; 2860 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2861 end; 2862 else if translate (current_token, UPPERCASE, LOWERCASE) = "WITH" then do; 2863 call next_real_token (); 2864 if current.type = WORD_TOKEN then 2865 current_relay.communications_protocol = current_token; 2866 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2867 end; 2868 else if translate (current_token, UPPERCASE, LOWERCASE) = "VIA" then do; 2869 call next_real_token (); 2870 if current.type = WORD_TOKEN then 2871 current_relay.communications_media = current_token; 2872 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2873 end; 2874 else if translate (current_token, UPPERCASE, LOWERCASE) = "ID" then do; 2875 /*** ID */ 2876 if current_relay.receiving_host = "" then 2877 call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2878 call next_real_token (); 2879 start_of_id_string = token_idx; 2880 if current.type = WORD_TOKEN then end_of_id_string = token_idx; 2881 else if current.type = LEFTBRACKET_TOKEN then do; 2882 bracket_level = 1; 2883 do while (bracket_level > 1); 2884 call next_real_token (); 2885 if current.type = LEFTBRACKET_TOKEN then bracket_level = bracket_level + 1; 2886 else if current.type = RIGHTBRACKET_TOKEN then 2887 bracket_level = bracket_level - 1; 2888 end; 2889 end_of_id_string = token_idx; 2890 end; 2891 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2892 message_id_string_lth = 2893 token_list.tokens (end_of_id_string).original_start 2894 - token_list.tokens (start_of_id_string).original_start 2895 + token_list.tokens (end_of_id_string).original_lth; 2896 begin; 2897 dcl message_id_string character (message_id_string_lth) unaligned defined (header_field_value) 2898 position (token_list.tokens (start_of_id_string).original_start); 2899 call encode_foreign_id (message_id_string, current_relay.receiving_host, 2900 current_relay.relay_id); 2901 end; 2902 end; 2903 else if translate (current_token, UPPERCASE, LOWERCASE) = "FOR" then do; 2904 /*** FOR
: must be last thing before semicolon */ 2905 local_ipo = p_ipo; 2906 string (local_ipo.delimiters) = ""b; 2907 call parse_address (p_pto, local_ipo, (token_idx + 1), current_relay.relay_recipient, 2908 code); 2909 if code ^= 0 then call bypass_relay_operation (code, "1"b); 2910 go to HAVE_FOUND_DATE_TIME_RELAYED; 2911 end; 2912 else do; /* kludge: assume other word is proceeded by WITH */ 2913 current_relay.communications_protocol = current_token; 2914 end; 2915 else call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2916 call next_real_token (); 2917 end; 2918 2919 HAVE_FOUND_DATE_TIME_RELAYED: 2920 if (current_relay.sending_host = "") | (current_relay.receiving_host = "") then 2921 call bypass_relay_operation (mlsys_et_$invalid_relayed_field_syntax, "1"b); 2922 2923 /*** Have everything now but the date/time relayed which uses a different lex/parse */ 2924 date_time_string_start = current.original_start + 1; 2925 2926 call lex_and_parse_epilogue ("1"b); /* get rid of the old token list */ 2927 call cu_$shrink_stack_frame (stack_extension_ptr, (0)); 2928 2929 begin; 2930 dcl date_time_string character (length (header_field_value) - date_time_string_start + 1) unaligned 2931 defined (header_field_value) position (date_time_string_start); 2932 call parse_date_time_text (p_pto, p_ipo, date_time_string, current_relay.date_time_relayed, code) 2933 ; 2934 if code ^= 0 then call bypass_relay_operation (code, "1"b); 2935 end; 2936 2937 relay_idx = relay_idx + 1; /* success */ 2938 2939 BYPASS_RELAY_OPERATION: 2940 end; 2941 2942 relay_idx = relay_idx - 1; /* above loop sets this value one too high */ 2943 2944 2945 /* Insure that the trace isn't empty */ 2946 2947 if (message_trace.implicit_route = null ()) & (relay_idx = 0) then do; 2948 free message_trace in (system_area); 2949 envelope.trace = null (); /* nothing in it */ 2950 end; 2951 2952 else message_trace.n_relays = relay_idx; /* insure it claims the right # of relays */ 2953 2954 return; 2955 2956 2957 /* Internal to parse_trace: aborts the parse of the Route field and continues to the parse of the Relayed fields */ 2958 2959 bypass_implicit_route: 2960 procedure (p_code, p_list_error) /* options (quick) */; 2961 2962 dcl p_code fixed binary (35) parameter; 2963 dcl p_list_error bit (1) aligned; 2964 2965 call lex_and_parse_epilogue ("1"b); /* most likely we interrupted something */ 2966 call cu_$shrink_stack_frame (stack_extension_ptr, (0)); 2967 2968 if trace_address ^= null () then call mail_system_$free_address (trace_address, (0)); 2969 2970 if message_trace.implicit_route ^= null () then 2971 free message_trace.implicit_route -> address_route in (system_area); 2972 2973 if p_list_error & p_pto.list_errors then 2974 call message_parse_error (p_pto, p_code, 2975 header_field_list.fields (field_idx).complete_field_start, 2976 header_field_list.fields (field_idx).complete_field_lth, ""); 2977 2978 go to BYPASS_IMPLICIT_ROUTE; 2979 2980 end bypass_implicit_route; 2981 2982 2983 2984 /* Internal to parse_trace: aborts the parse of the current Relayed field and proceeds to the next one */ 2985 2986 bypass_relay_operation: 2987 procedure (p_code, p_list_error) /* options (quick) */; 2988 2989 dcl p_code fixed binary (35); 2990 dcl p_list_error bit (1) aligned parameter; 2991 2992 call lex_and_parse_epilogue ("1"b); /* most likely we interrupted something */ 2993 call cu_$shrink_stack_frame (stack_extension_ptr, (0)); 2994 2995 if trace_address ^= null () then call mail_system_$free_address (trace_address, (0)); 2996 2997 if current_relay.relay_recipient ^= null () then 2998 call mail_system_$free_address (current_relay.relay_recipient, (0)); 2999 3000 if p_list_error & p_pto.list_errors then 3001 call message_parse_error (p_pto, p_code, 3002 header_field_list.fields (field_idx).complete_field_start, 3003 header_field_list.fields (field_idx).complete_field_lth, ""); 3004 3005 go to BYPASS_RELAY_OPERATION; 3006 3007 end bypass_relay_operation; 3008 3009 end parse_trace; 3010 3011 end parse_envelope; 3012 3013 /* Parse the address lists in the header corresponding to the given field */ 3014 3015 parse_address_list_field: 3016 procedure (p_pto, p_ipo, p_fieldname, p_field_list_ptr, p_address_list_ptr); 3017 3018 dcl 1 p_pto aligned like parse_text_options parameter; 3019 dcl 1 p_ipo aligned like internal_parse_options parameter; 3020 dcl p_fieldname character (*) varying parameter; 3021 dcl p_field_list_ptr pointer parameter; 3022 dcl p_address_list_ptr pointer parameter; 3023 3024 dcl 1 field_list aligned based (p_field_list_ptr) like field_by_type_lists.types; 3025 dcl idx fixed binary; 3026 3027 3028 call create_address_list (ADDRESS_LIST_VERSION_2, p_address_list_ptr, code); 3029 if code ^= 0 then call message_parse_error_fatal (code); 3030 /* all our software assumes address lists are never null */ 3031 3032 do idx = 1 to field_list.n_fields; 3033 field_idx = field_list.field_idxs (idx); 3034 call parse_address_list_text_internal (p_pto, p_ipo, header_field_value, p_address_list_ptr, code); 3035 if code ^= 0 then call message_parse_error_fatal (code); 3036 /* only happens if caller asked not to continue on error */ 3037 call merge_error_lists (p_fieldname); /* if listing errors: add any errors we find to the list */ 3038 end; 3039 3040 return; 3041 3042 3043 3044 /* Internal to parse_address_list_field: merge the results of an address list parse into the running results for the 3045* message parse */ 3046 3047 merge_error_lists: 3048 procedure (p_fieldname); 3049 3050 dcl p_fieldname character (*) varying parameter; 3051 3052 dcl new_ptel_ptr pointer; 3053 dcl (n_previous_errors, text_offset, idx, offset_idx) fixed binary; 3054 3055 if parse_text_options.list_errors & (lex_and_parse_pointers.sel_ptr ^= null ()) & (n_syntax_errors > 0) 3056 then do; /* something did go wrong */ 3057 message_parse_fails = "1"b; /* ... be sure global code will be set properly */ 3058 3059 if parse_text_error_list_ptr = null () then 3060 parse_text_error_list_n_errors = n_syntax_errors; 3061 else parse_text_error_list_n_errors = parse_text_error_list.n_errors + n_syntax_errors; 3062 n_previous_errors = parse_text_error_list_n_errors - n_syntax_errors; 3063 3064 allocate parse_text_error_list in (user_area) set (new_ptel_ptr); 3065 3066 do idx = 1 to n_previous_errors; 3067 new_ptel_ptr -> parse_text_error_list.errors (idx) = parse_text_error_list.errors (idx); 3068 end; 3069 3070 if parse_text_error_list_ptr ^= null () then free parse_text_error_list in (user_area); 3071 parse_text_error_list_ptr = new_ptel_ptr; 3072 3073 text_offset = charno (addr (header_field_value)) - charno (representation_ptr); 3074 3075 do idx = 1 to n_syntax_errors; 3076 offset_idx = idx + n_previous_errors; 3077 /* ... get right place in the complete list */ 3078 parse_text_error_list.errors (offset_idx).text_start = sel (idx).text_start + text_offset; 3079 parse_text_error_list.errors (offset_idx).text_lth = sel (idx).text_lth; 3080 parse_text_error_list.errors (offset_idx).code = sel (idx).code; 3081 if length (p_fieldname) > 0 then 3082 parse_text_error_list.errors (offset_idx).additional_info = 3083 "In the " || p_fieldname || " field:"; 3084 else parse_text_error_list.errors (offset_idx).additional_info = ""; 3085 end; 3086 end; 3087 3088 call lex_and_parse_epilogue ("1"b); /* get rid of syntax error list */ 3089 3090 return; 3091 3092 end merge_error_lists; 3093 3094 end parse_address_list_field; 3095 3096 /* Parse a single address */ 3097 3098 parse_address: 3099 procedure (p_pto, p_ipo, p_token_idx, p_address_ptr, p_code); 3100 3101 dcl 1 p_pto aligned like parse_text_options parameter; 3102 dcl 1 p_ipo aligned like internal_parse_options parameter; 3103 dcl p_token_idx fixed binary (21) parameter; /* where the address starts/stops */ 3104 dcl p_address_ptr pointer parameter; /* set -> the address generated (if any) */ 3105 dcl p_code fixed binary (35) parameter; 3106 3107 dcl 1 saved_p_ipo aligned like internal_parse_options; 3108 3109 dcl foreign_system_name character (256) varying; 3110 dcl address_pathname character (200); 3111 dcl address_dirname character (168); 3112 dcl (address_ename, address_component) character (32); 3113 dcl trimmed_address_ename character (32) varying; 3114 dcl new_host_indeces_ptr pointer; 3115 dcl (first_token_in_address, last_token_in_address, delimiting_token, address_name_start, address_name_end, idx) 3116 fixed binary (21); 3117 dcl (in_named_address, seen_route, address_is_local, is_mte, done) bit (1) aligned; 3118 dcl error_table_$noentry fixed bin(35) ext static; 3119 dcl search_paths_$find_dir entry (char(*), ptr, char(*), char(*), char(*), fixed bin(35)); 3120 dcl suffixed_name_$make entry (char(*), char(*), char(32), fixed bin(35)); 3121 3122 3123 p_address_ptr = null (); /* in case it fails */ 3124 3125 saved_p_ipo = p_ipo; /* for cleanup handler */ 3126 new_host_indeces_ptr, address_route_ptr = null (); 3127 3128 on condition (cleanup) 3129 begin; 3130 p_ipo = saved_p_ipo; 3131 if new_host_indeces_ptr ^= null () then free new_host_indeces_ptr -> host_indeces in (system_area); 3132 if address_route_ptr ^= null () then free address_route in (system_area); 3133 end; 3134 3135 call make_token_current (p_token_idx); 3136 delimiting_token = 0; /* haven't gotten that far yet */ 3137 3138 address_name_start, address_name_end = 0; /* no address name as yet */ 3139 in_named_address = "0"b; 3140 3141 seen_route = "0"b; /* no RFC822 address route */ 3142 3143 3144 START_ADDRESS_PARSE: 3145 n_hosts, n_reversed_hosts = 0; /* haven't seen any routing information */ 3146 3147 first_token_in_address = token_idx + 1; 3148 3149 call next_real_token (); /* move to the first token */ 3150 3151 START_ADDRESS_PARSE_WITH_ROUTE: 3152 if ^in_named_address & end_of_address () then 3153 /*** No non-comment tokens in the address (sigh) */ 3154 call bad_address_syntax (mlsys_et_$empty_address_text); 3155 3156 else if current.type = COLON_TOKEN then 3157 /*** an RFC733 structured address: no one understands them anymore */ 3158 call bad_address_syntax (mlsys_et_$obsolete_address_syntax); 3159 3160 else if in_named_address & (current.type = AT_TOKEN) then 3161 /*** RFC822-style explicit route (@HOST,@HOST,...:ADDR) */ 3162 if seen_route then 3163 call bad_address_syntax (mlsys_et_$multiple_address_routes); 3164 else do; 3165 seen_route = "1"b; /* don't let this happen again */ 3166 done = "0"b; 3167 do while (^done); 3168 n_hosts, n_reversed_hosts = n_hosts + 1; 3169 host_indeces (n_hosts) = token_idx; 3170 call next_real_token (); 3171 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$missing_host_name); 3172 call next_real_token (); /* skip past the host name */ 3173 if current.type = COLON_TOKEN then done = "1"b; 3174 else if current.type = COMMA_TOKEN then do; 3175 /* more of the route follows */ 3176 call next_real_token (); 3177 if current.type ^= AT_TOKEN then 3178 call bad_address_syntax (mlsys_et_$only_address_route_allowed); 3179 end; 3180 else call bad_address_syntax (mlsys_et_$only_address_route_allowed); 3181 end; 3182 first_token_in_address = token_idx + 1; /* address starts after the colon */ 3183 call next_real_token (); /* skip over the colon to the address itself */ 3184 go to START_ADDRESS_PARSE_WITH_ROUTE; 3185 end; 3186 3187 else if current.type = LEFTBRACE_TOKEN then do; 3188 /*** A structured address */ 3189 do while (current.type ^= RIGHTBRACE_TOKEN); /* lex has guarenteed that the braces balance */ 3190 call next_real_token (); /* move to the end of the structured part */ 3191 end; 3192 call next_real_token (); /* move past the } */ 3193 do while (^end_of_address ()); /* may be followed by routing information only */ 3194 if current.type ^= AT_TOKEN then call bad_address_syntax (mlsys_et_$only_address_route_allowed); 3195 n_hosts = n_hosts + 1; 3196 host_indeces (n_hosts) = token_idx; 3197 call next_real_token (); /* past the AT ... */ 3198 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$missing_host_name); 3199 call next_real_token (); /* ... and the host name following it */ 3200 end; 3201 end; 3202 3203 else do; 3204 3205 /*** Simple address, named address, or a named group address */ 3206 do while (^end_of_address ()); 3207 3208 if current.type = LEFTBRACKET_TOKEN then 3209 /*** A named address */ 3210 if in_named_address then 3211 call bad_address_syntax (mlsys_et_$recursive_named_addresses); 3212 else do; /* ... looks OK: start parse over terminating at ">" */ 3213 address_name_start = first_token_in_address; 3214 address_name_end = token_idx - 1; 3215 in_named_address = "1"b; 3216 string (p_ipo.delimiters) = ""b; 3217 p_ipo.delimiters.angle_bracket = "1"b; 3218 go to START_ADDRESS_PARSE; 3219 end; 3220 3221 else if current.type = COLON_TOKEN then 3222 /*** A named group */ 3223 if in_named_address then 3224 call bad_address_syntax (mlsys_et_$recursive_named_addresses); 3225 else do; 3226 call parse_named_group (); 3227 go to RETURN_FROM_PARSE_ADDRESS; 3228 end; /* ... the internal procedure does all the necessary work */ 3229 3230 else if current.type = AT_TOKEN then do; 3231 /*** A possible host name: remember it for later */ 3232 n_hosts = n_hosts + 1; 3233 host_indeces (n_hosts) = token_idx; 3234 call next_real_token (); 3235 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$missing_host_name); 3236 end; 3237 3238 else if current.type = WORD_TOKEN 3239 /*** Part of the address proper */ 3240 then 3241 ; 3242 3243 else call bad_address_syntax (mlsys_et_$invalid_address_syntax); 3244 3245 call next_real_token (); /* move right along */ 3246 end; 3247 end; 3248 3249 if in_named_address then do; 3250 /*** End of named address processing: insure that proper delimiter follows the ">" */ 3251 last_token_in_address = token_idx - 1; /* ... don't include the ">" as part of the address */ 3252 in_named_address = "0"b; 3253 p_ipo = saved_p_ipo; 3254 call next_real_token (); 3255 if ^end_of_address () then call bad_address_syntax (mlsys_et_$text_follows_address); 3256 end; 3257 else last_token_in_address = 0; /* don't know where it ends yet */ 3258 3259 3260 /* Determine the system of residence and construct the address route */ 3261 3262 delimiting_token = token_idx; 3263 3264 if n_hosts = 0 then do; /* no system/route given: use the default */ 3265 if last_token_in_address = 0 then /* ... haven't seen the end because of a named address ... */ 3266 last_token_in_address = token_idx - 1; /* ... so it's all address */ 3267 address_is_local = p_ipo.default_system_is_local; 3268 foreign_system_name = p_ipo.default_system_name; 3269 end; 3270 3271 else do; /* have system and/or route */ 3272 address_is_local = "0"b; /* ... can't be sure until we try to validate it */ 3273 if n_reversed_hosts > 0 then do; /* ... need to put host names into proper order */ 3274 allocate host_indeces in (system_area) set (new_host_indeces_ptr); 3275 do idx = 1 to n_reversed_hosts; 3276 new_host_indeces_ptr -> host_indeces (n_hosts - idx + 1) = host_indeces (idx); 3277 end; 3278 do idx = (n_reversed_hosts + 1) to n_hosts; 3279 new_host_indeces_ptr -> host_indeces (idx - n_reversed_hosts) = host_indeces (idx); 3280 end; 3281 if baseno (lex_and_parse_pointers.host_indeces_ptr) ^= baseno (stackframeptr ()) then 3282 free host_indeces in (system_area); 3283 lex_and_parse_pointers.host_indeces_ptr = new_host_indeces_ptr; 3284 new_host_indeces_ptr = null (); 3285 end; 3286 last_token_in_address = host_indeces (1) - 1; 3287 call make_token_current (host_indeces (1)); 3288 call next_real_token (); /* ... first host name is the foreign system */ 3289 foreign_system_name = current_token; /* ... above code insured this is the right kind of token */ 3290 do idx = 2 to n_hosts; /* ... move the remaining hosts (the route) down by 1 */ 3291 host_indeces (idx - 1) = host_indeces (idx); 3292 end; 3293 n_hosts = n_hosts - 1; 3294 end; 3295 3296 if n_hosts = 0 then /* no explicit route */ 3297 address_route_ptr = null (); 3298 else do; 3299 address_route_n_relays = n_hosts; 3300 allocate address_route in (system_area) set (address_route_ptr); 3301 address_route.version = ADDRESS_ROUTE_VERSION_1; 3302 do idx = 1 to n_hosts; 3303 call make_token_current (host_indeces (idx)); 3304 call next_real_token (); 3305 address_route.relays (n_hosts - idx + 1) = current_token; 3306 end; /* ... the printed representation is backward */ 3307 end; 3308 3309 3310 /* Get the address name and comment */ 3311 3312 if address_name_start = 0 then 3313 address_name = ""; /* no address name */ 3314 else call build_string (address_name_start, address_name_end, "1"b, "0"b, "1"b, address_name); 3315 3316 call build_string ((p_token_idx + 1), (delimiting_token - 1), "0"b, "1"b, "1"b, address_comment); 3317 3318 3319 /* Construct the actual address */ 3320 3321 if address_is_local then do; /* a local address */ 3322 call make_token_current (first_token_in_address); 3323 /* back to the beginning */ 3324 3325 if current.type = COMMENT_TOKEN then /* skip past comment to the first real token */ 3326 call next_real_token (); 3327 3328 if token_idx > last_token_in_address then /* a null address */ 3329 call bad_address_syntax (mlsys_et_$empty_address_text); 3330 3331 else if current.type = LEFTBRACE_TOKEN then do; 3332 /*** A structued address: validate it ... */ 3333 call next_real_token (); /* should be followed by the type of address */ 3334 if current.type ^= WORD_TOKEN then 3335 call bad_address_syntax (mlsys_et_$unknown_structured_address_type); 3336 3337 if translate (current_token, UPPERCASE, LOWERCASE) = "LOGBOX" then do; 3338 /*** The user's logbox ... */ 3339 call next_real_token (); /* should be the close brace */ 3340 if current.type ^= RIGHTBRACE_TOKEN then 3341 call bad_address_syntax (mlsys_et_$text_follows_address); 3342 call mail_system_$create_logbox_address (mlsys_data_$user_id, address_name, address_comment, 3343 p_address_ptr, code); 3344 if code ^= 0 then call bad_address_syntax (code); 3345 end; 3346 3347 else if translate (current_token, UPPERCASE, LOWERCASE) = "SAVE" then do; 3348 /*** One of the user's saveboxes ... */ 3349 call next_real_token (); /* should be the savebox pathname */ 3350 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected); 3351 if has_suffix (current_token, ".sv") then 3352 address_pathname = substr (current_token, 1, (length (current_token) - length (".sv"))); 3353 else address_pathname = current_token; 3354 call next_real_token (); /* should be the closing brace */ 3355 if current.type ^= RIGHTBRACE_TOKEN then 3356 call bad_address_syntax (mlsys_et_$text_follows_address); 3357 if search (address_pathname, "<>") = 0 then do; 3358 call suffixed_name_$make (address_pathname, "sv.mbx", address_ename, code); 3359 if code ^= 0 then call bad_address_syntax (code); 3360 call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code); 3361 if code = error_table_$noentry then 3362 call expand_pathname_$add_suffix (address_pathname, "sv.mbx", address_dirname, address_ename, code); 3363 if code ^= 0 then address_dirname = ""; 3364 end; 3365 else 3366 call expand_pathname_$add_suffix (address_pathname, "sv.mbx", address_dirname, address_ename, 3367 code); 3368 if code ^= 0 then call bad_address_syntax (code); 3369 call reject_starnames (address_ename, ""); 3370 call mail_system_$create_savebox_address (mlsys_data_$user_id, address_dirname, address_ename, 3371 address_name, address_comment, p_address_ptr, code); 3372 if code ^= 0 then call bad_address_syntax (code); 3373 end; 3374 3375 else if translate (current_token, UPPERCASE, LOWERCASE) = "MBX" then do; 3376 /*** A random mailbox ... */ 3377 call next_real_token (); /* should be the mailbox pathname */ 3378 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected); 3379 address_pathname = current_token; 3380 call next_real_token (); /* should be the closing brace */ 3381 if current.type ^= RIGHTBRACE_TOKEN then 3382 call bad_address_syntax (mlsys_et_$text_follows_address); 3383 if search (address_pathname, "<>") = 0 then do; 3384 call suffixed_name_$make (address_pathname, "mbx", address_ename, code); 3385 if code ^= 0 then call bad_address_syntax (code); 3386 call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code); 3387 if code = error_table_$noentry then 3388 call expand_pathname_$add_suffix (address_pathname, "mbx", address_dirname, address_ename, code); 3389 if code ^= 0 then address_dirname = ""; 3390 end; 3391 else 3392 call expand_pathname_$add_suffix (address_pathname, "mbx", address_dirname, address_ename, code); 3393 if code ^= 0 then call bad_address_syntax (code); 3394 call reject_starnames (address_ename, ""); 3395 call mail_system_$create_mailbox_address (address_dirname, address_ename, address_name, 3396 address_comment, p_address_ptr, code); 3397 if code ^= 0 then call bad_address_syntax (code); 3398 end; 3399 3400 else if translate (current_token, UPPERCASE, LOWERCASE) = "FORUM" then do; 3401 /*** A forum meeting ... */ 3402 call next_real_token (); /* should be the meeting pathname */ 3403 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected); 3404 address_pathname = current_token; 3405 call next_real_token (); /* should be the closing brace */ 3406 if current.type ^= RIGHTBRACE_TOKEN then 3407 call bad_address_syntax (mlsys_et_$text_follows_address); 3408 if search (address_pathname, "<>") = 0 then do; 3409 /*** ... not a pathname: must find the meeting by search list */ 3410 if length (rtrim (address_pathname)) > length (address_ename) then 3411 call bad_address_syntax (error_table_$entlong); 3412 address_ename = substr (address_pathname, 1, length (address_ename)); 3413 if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then 3414 if length (rtrim (address_ename)) > (length (address_ename) - length (".forum")) then 3415 call bad_address_syntax (error_table_$entlong); 3416 call reject_starnames (address_ename, ""); 3417 if mlsys_psp_$forum_not_available () then 3418 /*** ... Forum PSP not here: we've done all we can; mlsys_transmit_ will do the rest */ 3419 address_dirname = ""; 3420 else do; 3421 /*** ... time to scan the search list */ 3422 if forum_search_list_ptr = null () then do; 3423 call search_paths_$get ("forum", sl_control_default, "", null (), system_area_ptr, 3424 sl_info_version_1, forum_search_list_ptr, code); 3425 if code ^= 0 then call bad_address_syntax (code); 3426 end; 3427 if has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control") then 3428 call search_forum_list (address_ename, address_dirname, code); 3429 else do; /* ... try version 2 then version 1 meeting ... */ 3430 trimmed_address_ename = rtrim (address_ename); 3431 call search_forum_list ((trimmed_address_ename || ".forum"), address_dirname, 3432 code); 3433 if code = 0 then 3434 address_ename = trimmed_address_ename || ".forum"; 3435 else do; 3436 call search_forum_list ((trimmed_address_ename || ".control"), 3437 address_dirname, code); 3438 if code = 0 then address_ename = trimmed_address_ename || ".control"; 3439 end; 3440 end; 3441 if code ^= 0 then /* ... couldn't be found */ 3442 address_dirname = ""; 3443 end; 3444 end; 3445 else do; 3446 /*** .... a pathname */ 3447 call expand_pathname_ (address_pathname, address_dirname, address_ename, code); 3448 if code ^= 0 then call bad_address_syntax (code); 3449 if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) then 3450 if length (rtrim (address_ename)) > (length (address_ename) - length (".forum")) then 3451 call bad_address_syntax (error_table_$entlong); 3452 call reject_starnames (address_ename, ""); 3453 if mlsys_psp_$forum_not_available () then 3454 ; /* ... no Forum PSP: we've done all we can */ 3455 else do; 3456 if ^(has_suffix (address_ename, ".forum") | has_suffix (address_ename, ".control")) 3457 then do; 3458 /*** ... must determine the meeting version */ 3459 trimmed_address_ename = rtrim (address_ename); 3460 address_ename = trimmed_address_ename || ".forum"; 3461 call forum_$get_forum_path (address_dirname, address_ename, ((168)" "), ((32)" "), 3462 code); 3463 if code ^= 0 then /* ... not version 2 */ 3464 if (length (trimmed_address_ename) + length (".control")) 3465 <= length (address_ename) then 3466 address_ename = trimmed_address_ename || ".control"; 3467 end; 3468 end; 3469 end; 3470 call mail_system_$create_forum_address (address_dirname, address_ename, address_name, 3471 address_comment, p_address_ptr, code); 3472 if code ^= 0 then call bad_address_syntax (code); 3473 end; 3474 3475 else if translate (current_token, UPPERCASE, LOWERCASE) = "LIST" then do; 3476 /*** A mailing list ... */ 3477 call next_real_token (); /* should be the mailing list pathname */ 3478 if current.type ^= WORD_TOKEN then call bad_address_syntax (mlsys_et_$address_pathname_expected); 3479 address_pathname = current_token; 3480 call next_real_token (); /* should be the closing brace */ 3481 if current.type ^= RIGHTBRACE_TOKEN then 3482 call bad_address_syntax (mlsys_et_$text_follows_address); 3483 call expand_pathname_$component_add_suffix (address_pathname, "mls", address_dirname, 3484 address_ename, address_component, code); 3485 if code ^= 0 then call bad_address_syntax (code); 3486 if search (address_pathname, "<>") = 0 then do; 3487 address_dirname = ""; 3488 call search_paths_$find_dir ("mlsys", null(), address_ename, "", address_dirname, code); 3489 if code = error_table_$noentry then 3490 call expand_pathname_$component_add_suffix (address_pathname, "mls", address_dirname, 3491 address_ename, address_component, code); 3492 if code ^= 0 then address_dirname = ""; 3493 end; 3494 if code ^= 0 then call bad_address_syntax (code); 3495 call reject_starnames (address_ename, address_component); 3496 call mail_system_$create_mailing_list_address (address_dirname, address_ename, address_component, 3497 address_name, address_comment, p_address_ptr, code); 3498 if code ^= 0 then call bad_address_syntax (code); 3499 end; 3500 3501 else call bad_address_syntax (mlsys_et_$unknown_structured_address_type); 3502 end; 3503 3504 else do; /* all text: user or mail table */ 3505 call build_string (first_token_in_address, last_token_in_address, "1"b, "0"b, "1"b, address_string); 3506 call mlsys_user_mte_syntax_$classify_and_validate (address_string, is_mte, ((32)" "), ((32)" "), code) 3507 ; 3508 if code ^= 0 then call bad_address_syntax (code); 3509 if is_mte then 3510 call mail_system_$create_mail_table_address (address_string, address_name, address_comment, 3511 p_address_ptr, code); 3512 else call mail_system_$create_user_mailbox_address (address_string, address_name, address_comment, 3513 p_address_ptr, code); 3514 if code ^= 0 then call bad_address_syntax (code); 3515 end; 3516 end; 3517 3518 else do; /* a foreign address */ 3519 call build_string (first_token_in_address, last_token_in_address, "1"b, "0"b, "1"b, address_string); 3520 call mail_system_$create_foreign_address (address_string, foreign_system_name, address_route_ptr, 3521 address_name, address_comment, p_address_ptr, code); 3522 if code ^= 0 then call bad_address_syntax (code); 3523 end; 3524 3525 if p_pto.validate_addresses then do; /* caller wants to be sure we can send it mail */ 3526 call mail_system_$validate_address (p_address_ptr, "1"b, code); 3527 if code ^= 0 then do; /* ... invalid */ 3528 if ^p_pto.include_invalid_addresses then call mail_system_$free_address (p_address_ptr, (0)); 3529 call bad_address_syntax (code); 3530 end; 3531 end; 3532 3533 code = 0; /* success */ 3534 3535 3536 /* Parse completed */ 3537 3538 RETURN_FROM_PARSE_ADDRESS: 3539 p_ipo = saved_p_ipo; /* cleanup */ 3540 if new_host_indeces_ptr ^= null () then free new_host_indeces_ptr -> host_indeces in (system_area); 3541 if address_route_ptr ^= null () then free address_route in (system_area); 3542 3543 call make_token_current (delimiting_token); /* show the delimiter to our caller */ 3544 p_token_idx = delimiting_token; 3545 3546 p_code = code; 3547 3548 return; 3549 3550 3551 3552 /* Internal to parse_address: reports syntax errors in the address */ 3553 3554 bad_address_syntax: 3555 procedure (p_code); 3556 3557 dcl p_code fixed binary (35) parameter; 3558 3559 dcl (brace_level, bracket_level, group_level) fixed binary (21); 3560 dcl string_lth fixed binary (21); 3561 3562 if delimiting_token = 0 then do; /* must determine last token now */ 3563 brace_level, bracket_level, group_level = 0; 3564 call make_token_current (first_token_in_address); 3565 if current.type = COMMENT_TOKEN then /* skip to the first real token */ 3566 call next_real_token (); 3567 if (current.type = COLON_TOKEN) then do;/* an RFC733 structured address */ 3568 call next_real_token (); 3569 call next_real_token (); /* past the structure type ... */ 3570 call next_real_token (); /* ... and the other colon */ 3571 end; 3572 do while ((current.type ^= END_OF_TEXT_TOKEN) & (delimiting_token = 0)); 3573 if (brace_level <= 0) & (bracket_level <= 0) & (group_level <= 0) then 3574 if end_of_address () then /* found the end of the address */ 3575 delimiting_token = token_idx; 3576 if (current.type = LEFTBRACE_TOKEN) then 3577 /* keep track of nesting in order to find proper terminator */ 3578 brace_level = brace_level + 1; 3579 else if (current.type = RIGHTBRACE_TOKEN) then brace_level = brace_level - 1; 3580 else if (current.type = LEFTBRACKET_TOKEN) then bracket_level = bracket_level + 1; 3581 else if (current.type = RIGHTBRACKET_TOKEN) then bracket_level = bracket_level - 1; 3582 else if (current.type = COLON_TOKEN) then group_level = group_level + 1; 3583 else if (current.type = SEMICOLON_TOKEN) then group_level = group_level - 1; 3584 call next_real_token (); /* keep looking */ 3585 end; 3586 if delimiting_token = 0 then /* hit the end */ 3587 delimiting_token = token_idx; 3588 end; 3589 3590 string_lth = /* may use this value in several places ... */ 3591 token_list.tokens (delimiting_token - 1).original_start 3592 - token_list.tokens (p_token_idx + 1).original_start 3593 + token_list.tokens (delimiting_token - 1).original_lth; 3594 string_lth = max (string_lth, 0); /* ... above is negative if original_text is a null string */ 3595 3596 n_syntax_errors = n_syntax_errors + 1; 3597 if p_pto.list_errors then do; /* caller wants to see the bad text */ 3598 sel (n_syntax_errors).text_start = token_list.tokens (p_token_idx + 1).original_start; 3599 sel (n_syntax_errors).text_lth = string_lth; 3600 sel (n_syntax_errors).code = p_code; 3601 end; 3602 3603 if p_pto.include_invalid_addresses & (p_address_ptr = null ()) then do; 3604 begin; /* caller wants it in the address list and it isn't already */ 3605 dcl the_string char (string_lth) defined (original_text) position (token_list.tokens (p_token_idx + 1).original_start); 3606 call mail_system_$create_invalid_address ((the_string), "", "", p_address_ptr, (0)); 3607 end; 3608 end; 3609 3610 code = p_code; /* set parse_address's output value */ 3611 3612 go to RETURN_FROM_PARSE_ADDRESS; 3613 3614 end bad_address_syntax; 3615 3616 3617 3618 /* Internal to parse_address: determines if the end of the address has been reached */ 3619 3620 end_of_address: 3621 procedure () returns (bit (1) aligned); 3622 3623 if p_ipo.delimiters.eos & (current.type = END_OF_TEXT_TOKEN) then return ("1"b); 3624 3625 else if (current.type = END_OF_TEXT_TOKEN) then do; 3626 /* shouldn't have reached the end: syntax error */ 3627 delimiting_token = token_idx; /* clearly the address stops here */ 3628 call bad_address_syntax (mlsys_et_$incomplete_address_text); 3629 end; 3630 3631 else if p_ipo.delimiters.comma & (current.type = COMMA_TOKEN) then return ("1"b); 3632 3633 else if p_ipo.delimiters.angle_bracket & (current.type = RIGHTBRACKET_TOKEN) then return ("1"b); 3634 3635 else if p_ipo.delimiters.semicolon & (current.type = SEMICOLON_TOKEN) then return ("1"b); 3636 3637 else return ("0"b); 3638 3639 end end_of_address; 3640 3641 3642 3643 /* Internal to parse_address: parses a named group */ 3644 3645 parse_named_group: 3646 procedure (); 3647 3648 dcl 1 local_pto aligned like parse_text_options; 3649 dcl 1 local_ipo aligned like internal_parse_options; 3650 3651 dcl an_address_list_ptr pointer; 3652 dcl (saved_n_syntax_errors, second_half_comment_start) fixed binary (21); 3653 3654 address_name_start = first_token_in_address; 3655 address_name_end = token_idx - 1; /* up to but not including the ":" */ 3656 3657 an_address_list_ptr = null (); /* parse_address_list will set it up */ 3658 3659 string (local_pto.flags) = ""b; /* don't list errors, etc. */ 3660 3661 local_ipo = p_ipo; /* copy most internal options */ 3662 string (local_ipo.delimiters) = ""b; /* ... except only stop on a semi-colon */ 3663 local_ipo.delimiters.semicolon = "1"b; 3664 3665 saved_n_syntax_errors = n_syntax_errors; /* we'll convert all errors into a single error */ 3666 call parse_address_list (local_pto, local_ipo, token_idx, an_address_list_ptr, code); 3667 n_syntax_errors = saved_n_syntax_errors; 3668 3669 if code ^= 0 then /* named group is bad: report a single, global error */ 3670 if code = mlsys_et_$incomplete_address_list_text then 3671 call bad_address_syntax (mlsys_et_$incomplete_named_group_text); 3672 else call bad_address_syntax (mlsys_et_$invalid_named_group_text); 3673 3674 second_half_comment_start = token_idx + 1; /* any comment after the semicolon is global */ 3675 3676 call next_real_token (); /* must be at the end now */ 3677 if ^end_of_address () then do; 3678 call free_address_list (an_address_list_ptr, (0)); 3679 call bad_address_syntax (mlsys_et_$text_follows_address); 3680 end; 3681 3682 delimiting_token = token_idx; /* for cleanup */ 3683 3684 call build_string (address_name_start, address_name_end, "1"b, "0"b, "1"b, address_name); 3685 call build_string (address_name_start, address_name_end, "0"b, "1"b, "1"b, address_comment); 3686 call build_string (second_half_comment_start, (delimiting_token - 1), "0"b, "1"b, "0"b, address_comment); 3687 /* pick up any remaining comment text */ 3688 3689 call mail_system_$create_named_group_address (address_name, an_address_list_ptr, "1"b, address_comment, 3690 p_address_ptr, code); 3691 if code ^= 0 then call bad_address_syntax (code); 3692 3693 return; 3694 3695 end parse_named_group; 3696 3697 3698 3699 /* Internal to parse_address: construct the text string consisting of all the tokens within the specified range */ 3700 3701 build_string: 3702 procedure (p_first_token, p_last_token, p_include_non_comments, p_include_comments, p_initialize_string, 3703 p_string); 3704 3705 dcl (p_first_token, p_last_token) fixed binary (21) parameter; 3706 dcl (p_include_non_comments, p_include_comments, p_initialize_string) bit (1) aligned parameter; 3707 dcl p_string character (*) varying parameter; 3708 dcl saved_current_token fixed binary (21); 3709 3710 if p_initialize_string then p_string = ""; 3711 3712 saved_current_token = token_idx; /* want to get back here when done */ 3713 call make_token_current (p_first_token); /* start here please */ 3714 3715 do while (token_idx <= p_last_token); /* for all tokens in the string */ 3716 if current.type = COMMENT_TOKEN then 3717 if p_include_comments then do; 3718 p_string = p_string || current_token; 3719 p_string = p_string || " "; 3720 end; 3721 else ; 3722 else do; 3723 if p_include_non_comments then do; 3724 p_string = p_string || current_token; 3725 p_string = p_string || " "; 3726 end; 3727 else ; 3728 end; 3729 call next_token (); /* next, please */ 3730 end; 3731 3732 if length (p_string) > 0 then /* it's one larger than it should be */ 3733 p_string = substr (p_string, 1, (length (p_string) - 1)); 3734 3735 call make_token_current (saved_current_token); 3736 /* back to where we were */ 3737 3738 return; 3739 3740 end build_string; 3741 3742 3743 3744 /* Internal to parse_address: rejects pathnames containing starnames */ 3745 3746 reject_starnames: 3747 procedure (p_ename, p_component); 3748 3749 dcl (p_ename, p_component) character (32) parameter; 3750 dcl code fixed binary (35); 3751 3752 call check_star_name_$entry (p_ename, code); /* first check the entryname */ 3753 if code = 0 then /* ... entryname OK: check the component name (if present) */ 3754 if p_component ^= "" then call check_star_name_$entry (p_component, code); 3755 3756 if (code = 1) | (code = 2) then code = error_table_$nostars; 3757 3758 if code ^= 0 then /* either a starname or invalid syntax */ 3759 call bad_address_syntax (code); 3760 3761 return; 3762 3763 end reject_starnames; 3764 3765 3766 3767 /* Internal to parse_address: returns "1"b if the given suffix is present on the supplied name */ 3768 3769 has_suffix: 3770 procedure (p_name, p_suffix) returns (bit (1) aligned); 3771 3772 dcl (p_name, p_suffix) character (*) parameter; 3773 3774 return ((index (reverse (rtrim (p_name)), reverse (p_suffix)) = 1)); 3775 3776 end has_suffix; 3777 3778 3779 3780 /* Internal to parse_address: scans the forum search list (already obtained above) for the given entryname */ 3781 3782 search_forum_list: 3783 procedure (p_ename, p_dirname, p_code); 3784 3785 dcl (p_ename, p_dirname) character (*) parameter; 3786 dcl p_code fixed binary (35) parameter; 3787 3788 dcl ename character (32) initial (""); 3789 dcl idx fixed binary; 3790 3791 if length (rtrim (p_ename)) > length (ename) then do; 3792 p_code = error_table_$entlong; /* ... constructed entry name is too long */ 3793 return; 3794 end; 3795 3796 p_code = 1; /* need do until ... */ 3797 3798 do idx = 1 to forum_search_list_ptr -> sl_info.num_paths while (p_code ^= 0); 3799 if forum_search_list_ptr -> sl_info.paths (idx).code = 0 then 3800 call forum_$get_forum_path (forum_search_list_ptr -> sl_info.paths (idx).pathname, p_ename, 3801 ((168)" "), ((32)" "), p_code); 3802 if p_code = 0 then p_dirname = forum_search_list_ptr -> sl_info.paths (idx).pathname; 3803 end; 3804 3805 return; 3806 3807 end search_forum_list; 3808 3809 end parse_address; 3810 3811 /* Parse an address list */ 3812 3813 parse_address_list: 3814 procedure (p_pto, p_ipo, p_token_idx, p_address_list_ptr, p_code); 3815 3816 dcl 1 p_pto aligned like parse_text_options parameter; 3817 dcl 1 p_ipo aligned like internal_parse_options parameter; 3818 dcl p_token_idx fixed binary (21) parameter; 3819 dcl p_address_list_ptr pointer; 3820 dcl p_code fixed binary (35) parameter; 3821 3822 dcl 1 local_ipo aligned like internal_parse_options; 3823 3824 dcl an_address pointer; 3825 dcl (first_token_in_address_list, last_token_in_address_list) fixed binary (21); 3826 dcl (previous_n_addresses) fixed binary; 3827 dcl (created_address_list, done) bit (1) aligned; 3828 3829 3830 local_ipo = p_ipo; /* use caller's options ... */ 3831 local_ipo.delimiters.comma = "1"b; /* ... but also allow a comma delimter */ 3832 3833 if p_address_list_ptr = null () then do; /* must create the list */ 3834 call create_address_list (ADDRESS_LIST_VERSION_2, p_address_list_ptr, code); 3835 if code ^= 0 then do; 3836 p_code = code; 3837 return; 3838 end; 3839 created_address_list = "1"b; 3840 end; 3841 else do; /* already something in the list ... */ 3842 created_address_list = "0"b; 3843 previous_n_addresses = p_address_list_ptr -> address_list.n_addresses; 3844 end; /* ... in case we have to flush what we add */ 3845 3846 call make_token_current (p_token_idx); /* peek ahead to the first token of the list ... */ 3847 call next_token (); /* ... to see if it's an empty list: only if at end-of-list */ 3848 3849 first_token_in_address_list = token_idx; /* here's where the list starts ... */ 3850 last_token_in_address_list = token_idx; /* ... and for now: it also ends here */ 3851 3852 done = end_of_address_list (); /* check for end-of-list before the first address */ 3853 3854 do while (^done); 3855 3856 call parse_address (p_pto, local_ipo, p_token_idx, an_address, code); 3857 last_token_in_address_list = token_idx - 1; /* ... the list now goes at least this far */ 3858 3859 if an_address ^= null () then do; /* have an address */ 3860 call add_address (p_address_list_ptr, an_address, ADDRESS_LIST_VERSION_2, code); 3861 if code ^= 0 then call bad_address_list_syntax (code); 3862 end; 3863 3864 else if ^p_pto.list_errors & ^p_pto.include_invalid_addresses then 3865 if code = 0 then /* caller hasn't asked us to continue */ 3866 call bad_address_list_syntax (mlsys_et_$invalid_address_list_syntax); 3867 else if code = mlsys_et_$incomplete_address_text then 3868 call bad_address_list_syntax (mlsys_et_$incomplete_address_list_text); 3869 else call bad_address_list_syntax (code); 3870 3871 done = end_of_address_list (); /* check if we're done yet */ 3872 end; 3873 3874 code = 0; /* success: caller will really set the code */ 3875 3876 RETURN_FROM_PARSE_ADDRESS_LIST: 3877 p_code = code; 3878 return; 3879 3880 3881 /* Internal to parse_address_list: reports syntax errors in the address list */ 3882 3883 bad_address_list_syntax: 3884 procedure (p_code); 3885 3886 dcl p_code fixed binary (35) parameter; 3887 3888 dcl string_lth fixed binary (21); 3889 dcl idx fixed binary; 3890 3891 if created_address_list then /* we created it; we destroy it */ 3892 call free_address_list (p_address_list_ptr, (0)); 3893 else do; /* we didn't create it: delete what we added */ 3894 do idx = p_address_list_ptr -> address_list.n_addresses to (previous_n_addresses + 1) by -1; 3895 call delete_address (p_address_list_ptr, idx, (0)); 3896 end; 3897 end; 3898 3899 string_lth = /* may use this value in several places ... */ 3900 token_list.tokens (last_token_in_address_list).original_start 3901 - token_list.tokens (first_token_in_address_list).original_start 3902 + token_list.tokens (last_token_in_address_list).original_lth; 3903 string_lth = max (string_lth, 0); /* ... above is negative if original_text is a null string */ 3904 3905 n_syntax_errors = n_syntax_errors + 1; 3906 if p_pto.list_errors then do; /* caller wants to see the bad text */ 3907 sel (n_syntax_errors).text_start = token_list.tokens (first_token_in_address_list).original_start; 3908 sel (n_syntax_errors).text_lth = string_lth; 3909 sel (n_syntax_errors).code = p_code; 3910 end; 3911 3912 code = p_code; /* set parse_address_list's output value */ 3913 3914 go to RETURN_FROM_PARSE_ADDRESS_LIST; 3915 3916 end bad_address_list_syntax; 3917 3918 3919 3920 /* Internal to parse_address_list: determines if the end of the address list has been reached */ 3921 3922 end_of_address_list: 3923 procedure () returns (bit (1) aligned); 3924 3925 if p_ipo.delimiters.eos & (current.type = END_OF_TEXT_TOKEN) then return ("1"b); 3926 3927 else if current.type = END_OF_TEXT_TOKEN then do; 3928 last_token_in_address_list = token_idx - 1; 3929 call bad_address_list_syntax (mlsys_et_$incomplete_address_list_text); 3930 end; 3931 3932 else if p_ipo.delimiters.comma & (current.type = COMMA_TOKEN) then return ("1"b); 3933 3934 else if p_ipo.delimiters.angle_bracket & (current.type = RIGHTBRACKET_TOKEN) then return ("1"b); 3935 3936 else if p_ipo.delimiters.semicolon & (current.type = SEMICOLON_TOKEN) then return ("1"b); 3937 3938 else return ("0"b); 3939 3940 end end_of_address_list; 3941 3942 end parse_address_list; 3943 3944 /* Convert the printed representation of a date/time into its internal form */ 3945 3946 parse_date_time_text: 3947 procedure (p_pto, p_ipo, p_date_time_text, p_date_time, p_code) /* options (quick) */; 3948 3949 dcl 1 p_pto aligned like parse_text_options parameter; 3950 dcl 1 p_ipo aligned like internal_parse_options parameter; 3951 dcl p_date_time_text character (*) parameter; 3952 dcl p_date_time fixed binary (71) parameter; 3953 dcl p_code fixed binary (35) parameter; 3954 3955 dcl date_time fixed binary (71); 3956 3957 dcl zone_name character (3); 3958 dcl zone_offset fixed binary (71); 3959 dcl (recognized_zone, standard_multics_zone, negative_offset) bit (1) aligned; 3960 3961 dcl code fixed binary (35); 3962 dcl start fixed binary (21); 3963 dcl (day_of_week, day_of_month, month, year, hour, minute, second, hour_offset, minute_offset, idx) fixed binary; 3964 3965 3966 call lex_and_parse_prologue (p_date_time_text, "0"b, "0"b); 3967 /* no cleanup handler here: caller's set one up already */ 3968 3969 call lex_date_time (p_pto, p_ipo, code); /* "-", "+", ":", and whitespace are delimiters */ 3970 if code ^= 0 then go to TRY_CONVERT_DATE_TO_BINARY; 3971 3972 3973 /* Syntax of a date is: [ [ "," ] ] [ "," ]