{ UUCP_mail implements the UUCP foreign protocol interface to the VMS MAIL system. The routines here are invoked by the more general foreign mail dispatcher in MAILSHR.MAR for the UUCP protocol. A UUCP address is indicated by any address of the form: uucp%"any-uucp-address-path" Note that the quoted string is required since UUCP host and user names are case-sensitive and contain "!"'s. UUCP_mail is invoked with a call to LIB$FIND_IMAGE_SYMBOL in MAIL. The shareable image containing this code may be placed in SYS$LIBRARY:UUCP_MAILSHR.EXE or it may be pointed to by the logical name MAIL$PROTOCOL_UUCP. Also, note that this code may serve as a template for writing interfaces to other foreign mail delivery systems. The dispatcher code in MAILSHR.MAR shouldn't need to change for another foreign protocol. Note: The foreign protocol interface within MAIL is undocumented at this time. It may change without notice in a future release of VMS. The information necessary to write this code comes from the MAIL source on the VMS microfiche. The most useful information is the routine NETJOB in module MAIL$MAIL (230-E2), which handles incoming foreign mail, and the various routines in module NETSUBS (230-N11), most of which deal with outgoing foreign mail. Incoming mail messages are handed to the VMS MAIL system through this module as well with a command of the form: $ mail/protocol=mail$protocol_UUCP message.txt username To route UUCP mail through this node, "username" can simply be a UUCP address of the form: uucp%"uucp-path". } [inherit ('SYS$LIBRARY:STARLET')] module UUCP_mail (Output); const DEBUG_ON = true; (* True for debugging purposes *) LNK_C_OUT_CONNECT = 0; (* MAIL protocol link actions. *) LNK_C_OUT_SENDER = 1; (* These are defined in MAILSHR.MAR *) LNK_C_OUT_CKUSER = 2; (* but because we cannot have external *) LNK_C_OUT_TO = 3; (* constants in Pascal, I redefined them *) LNK_C_OUT_SUBJ = 4; (* here. *) LNK_C_OUT_FILE = 5; LNK_C_OUT_CKSEND = 6; LNK_C_OUT_DEACCESS = 7; LNK_C_IN_CONNECT = 8; LNK_C_IN_SENDER = 9; LNK_C_IN_CKUSER = 10; LNK_C_IN_TO = 11; LNK_C_IN_SUBJ = 12; LNK_C_IN_FILE = 13; LNK_C_IO_READ = 14; LNK_C_IO_WRITE = 15; short_string_length = 80; message_line_max = 1000; (* Max chars in a line of text, hate to have a limit on this, but VMS requires it. *) (* * This is a special UUCP directory where we put our text files for outbound * messages. Note that this directory has default ACLs on it so mail messages * written into it are not readable by anyone except UUCP, who can also delete * them. *) temp_dir = 'UUCP_ROOT:[SPOOL.UUCP.XTMP]'; stack_size = 10; (* State mach. stack for messages from MAIL *) type FAB_ptr = ^FAB$TYPE; str_16 = packed array [1..16] of char; String = varying [message_line_max] of char; short_string = varying [short_string_length] of char; string_descriptor = record length, address : unsigned; end; write_states = (unexpected_message, user_check, delivery_check, error_text_expected); write_state_stack = record top : integer; store : array [1..stack_size] of write_states; end; Addr_list_ptr = ^Addr_list; Addr_list = record Next : Addr_list_ptr; extension : str_16; Name : String; cmd_file, message_file : text; end; (* * The following structures define message headers as described in the * Standard for ARPA Internet Text Message (RFC 822). * * Have to be very careful here. The known field names' enumerated values * MUST correspond to the values defined in the LIB$TPARSE module, so that * it can return the appropriate type after a successful parse. Therefore, * do NOT change this enumerated type without changing the appropriate list * of constants in PARSE_TABLES.MAR. Sure wish I had global constants in this * language. *) known_field_names = (fld_received, fld_date, fld_from, fld_to, fld_subject, fld_continuation, fld_unknown, fld_old_UUCP_from, error_line); field_ptr = ^field; field = record field_body : string; next : field_ptr; field_name_text : short_string; case field_name : known_field_names of fld_from : (address : ^string); end; header_types = (no_headers, rfc_822_headers, UUCP_headers); header_list_ptr = ^header_list; header_list = record first_field : field_ptr; to_field, from_field, UUCP_from_field, subj_field : field_ptr; header_type : header_types; from : string; remote_name : short_string; end; Message_info_ptr = ^Message_info; Message_info = record addresses : addr_list_ptr; subject_line, from_line, to_line, personal_name : string; headers : header_list_ptr; requests_file : text; (* stuff from here down is used only by inbound mailer *) write_recv_states : write_state_stack; message_file : string; message_text : text; end; var UUCP$_BADADDR, UUCP$_MESFILERR, UUCP$_INTCODERR, UUCP$_STKOVRFLO, UUCP$_STKEMPTY, UUCP$_NORECIP, UUCP$_GETFILERR, UUCP$_BADSTATE, UUCP$_MSGWRTERR, UUCP$_NILADRFND : [external, readonly] integer; CLI$_ABSENT : [external, readonly] integer; Null_byte : [readonly] String := ''(0); {------------------------- External routines -----------------------------} procedure LIB$SIGNAL (%IMMED stat : [list, unsafe] integer); extern; function LIB$SYS_TRNLOG (Logical_name : Varying [Max1] of Char; var Dst_len : Integer := %Immed 0; var Dest_string : Varying [Max2] of Char; var Table : Integer := %Immed 0; var Acc_mode : Integer := %Immed 0; dsb_mask : Integer := 0 ) : Integer; Extern; [asynchronous, unbound] function LIB$TPARSE (var arg_blk : TPA$TYPE; %REF state_tbl, key_tbl : [unsafe] integer ) : integer; extern; function CLI$GET_VALUE (name : varying [Max1] of char; var val : varying [Max2] of char ) : integer; extern; [asynchronous, unbound, external (LIB$SCOPY_DXDX)] function Strdesc_to_varying (var src : string_descriptor; var dst : varying [maxlen] of char ) : integer; extern; [asynchronous, unbound, external (LIB$SCOPY_DXDX)] function Varying_to_strdesc (var src : varying [maxlen] of char; var dst : string_descriptor ) : integer; extern; {============================ Routines for debugging purposes ==============} procedure DEBUG_dump_headers (hdr : header_list_ptr); var walker : field_ptr; begin (* DEBUG_dump_headers *) writeln ('================== H E A D E R S ==========================='); walker := hdr^.first_field; while walker <> nil do begin writeln ('name: ', walker^.field_name); writeln (' : |', walker^.field_name_text, '|'); writeln ('body: |', walker^.field_body, '|'); if walker^.field_name = fld_from then if walker^.address <> nil then writeln ('address: |', walker^.address^, '|') else writeln ('address: -- not available --'); walker := walker^.next; if walker <> nil then writeln ('-----------------------------------------------------'); end; writeln ('=============================================================='); writeln ('These headers are ', hdr^.header_type); writeln ('To line: '); if hdr^.to_field <> nil then writeln (' |', hdr^.to_field^.field_body, '|') else writeln (' no line available'); writeln ('From line: '); writeln (' |', hdr^.from, '|'); writeln ('Subj line: '); if hdr^.subj_field <> nil then writeln (' |', hdr^.subj_field^.field_body, '|') else writeln (' no line available'); end; (* DEBUG_dump_headers *) {=============================================================================} {------------------------------------------------------------------------------ "Strings_are_equal" compares two varying strings, even if they are different lengths. If the lengths are not identical, then they are immediately considered non equal. } function Strings_are_equal (Str1 : varying [Len1] of Char; Str2 : varying [Len2] of Char) : Boolean; begin (* Strings_are_equal *) Strings_are_equal := False; if Length (Str1) = Length (Str2) then if Str1 = Str2 then Strings_are_equal := True; end; (* Strings_are_equal *) {------------------------------------------------------------------------------ "Begins_with" checks to see if the string in the first argument is prefixed by the string in the second argument. } function Begins_with (Str1 : varying [Len1] of Char; Str2 : varying [Len2] of Char) : Boolean; begin (* Begins_with *) Begins_with := False; if Length (Str1) >= Length (Str2) then if substr (Str1, 1, Length (Str2)) = Str2 then Begins_with := True; end; (* Begins_with *) {------------------------------------------------------------------------------ "String_to_integer" converts a varying string into an integer by assuming the first four bytes in the string are simply a number. This is the way MAIL likes to pass status codes and such. If the string is not of length four, then it probably isn't a number. We return a 0 in that case. } function String_to_integer (str : varying [Len1] of Char) : integer; var number : packed array [1..4] of char; begin (* String_to_integer *) if Length (Str) <> 4 then String_to_integer := 0 else begin number := str; String_to_integer := number :: integer; end; end; (* String_to_integer *) {------------------------------------------------------------------------------ "Make_unique_name" generates a unique string by getting the system date and time in binary and converting it to hex. This should never repeat. } function Make_unique_name : str_16; var stat : integer; sys_time : record l1, l2 : unsigned; end; begin (* Make_unique_name *) stat := $GETTIM (TIMADR := sys_time); if not odd (stat) then LIB$SIGNAL (stat); Make_unique_name := Hex (sys_time.l2, 8, 8) + Hex (sys_time.l1, 8, 8); end; (* Make_unique_name *) {------------------------------------------------------------------------------ "Valid_address" checks to see if an address is a valid UUCP address. Currently just check that it has a "!" in it somewhere and that the "!" isn't the first or last character. } function Valid_address (address_str : varying [maxlen] of char) : boolean; begin (* Valid_address *) if (length (address_str) = 0) or (index (address_str, '!') = 0) then Valid_address := false else if (address_str[1] = '!') or (address_str[length (address_str)] = '!') then Valid_address := false else Valid_address := true; end; (* Valid_address *) {------------------------------------------------------------------------------ "Trim_trailing_blanks" does just that. } procedure Trim_trailing_blanks (var str : varying [maxlen1] of char); [asynchronous, unbound] function STR$TRIM (var dst : varying [maxlen1] of char; var src : varying [maxlen2] of char ) : integer; extern; begin (* Trim_trailing_blanks *) STR$TRIM (str, str); end; (* Trim_trailing_blanks *) {------------------------------------------------------------------------------ "Trim_leading_blanks" does just that. } procedure Trim_leading_blanks (var str : varying [maxlen1] of char); [asynchronous, unbound] function STR$FIND_FIRST_NOT_IN_SET (var str : varying [maxlen1] of char; cset : varying [maxlen2] of char ) : integer; extern; [asynchronous, unbound] function STR$RIGHT (var dst : varying [maxlen1] of char; var src : varying [maxlen2] of char; start_pos : integer ) : integer; extern; const space = ' '; tab = ''(9)''; var i : integer; begin (* Trim_leading_blanks *) i := STR$FIND_FIRST_NOT_IN_SET (str, space + tab); if i = 0 then str := '' else STR$RIGHT (str, str, i); end; (* Trim_leading_blanks *) {------------------------------------------------------------------------------ "Replace_string" replaces all occurances of SRCH with REPL in DST. } procedure Replace_string (var dst : varying [m1] of char; srch : varying [m2] of char; repl : varying [m3] of char); [asynchronous, unbound] function STR$POSITION (var src : varying [maxlen1] of char; var substr : varying [maxlen2] of char; start_pos : integer ) : integer; extern; [asynchronous, unbound] function STR$REPLACE (var dst : varying [ml1] of char; var src : varying [ml2] of char; start_pos : integer; end_pos : integer; var rpl : varying [ml3] of char ) : integer; extern; var pos, start : integer; done : boolean; begin (* Replace_string *) start := 1; repeat pos := STR$POSITION (dst, srch, start); done := (pos = 0) or (length (srch) = 0); if not done then begin STR$REPLACE (dst, dst, pos, pos + length (srch) - 1, repl); start := pos + length (repl); end; until done; end; (* Replace_string *) {------------------------------------------------------------------------------ "ARPA_date_time" returns a string which is the current system date and time in the syntax specifed in RFC-822 under "Date and Time Specification". Note that the zone field is gotten by translating the logical name MAIL_TIME_ZONE. If we get any sort of error doing the translation, we assume it's not available and do not include a time zone. Note that this will work, but that the time zone is a required portion of the date-time specification. } function ARPA_date_time : short_string; type string_3 = packed array [1..3] of char; u_quad = record l,h : unsigned; end; var VMS_time, time_zone : short_string; stat, day_of_week : integer; days : [static] array [1..7] of packed array [1..3] of char := ('Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat', 'Sun'); function LIB$DATE_TIME (var str : varying [max] of char) : Integer; Extern; function LIB$DAY_OF_WEEK (time : u_quad := %IMMED 0; var day_num : integer) : integer; extern; function Capitolize (str : string_3) : short_string; begin (* Capitolize *) str[2] := chr (ord (str[2]) + ord (' ')); str[3] := chr (ord (str[3]) + ord (' ')); capitolize := str; end; (* Capitolize *) begin (* ARPA_date_time *) LIB$DATE_TIME (VMS_time); LIB$DAY_OF_WEEK (, day_of_week); stat := LIB$SYS_TRNLOG ('MAIL_TIME_ZONE', , time_zone); if stat <> SS$_NORMAL then time_zone := ''; ARPA_date_time := days[day_of_week] + ', ' + substr (VMS_time, 1, 2) + ' ' + capitolize (substr (VMS_time, 4, 3)) + ' ' + substr (VMS_time, 10, 2) + ' ' + substr (VMS_time, 13, 8) + ' ' + time_zone; end; (* ARPA_date_time *) {------------------------------------------------------------------------------ "Remove_ARPA_comments" removes substrings bracketed by balanced parentheses. } procedure Remove_ARPA_comments (var str : varying [maxlen] of char); var temp_str : string; in_comment, in_quote, escaped : boolean; i : integer; begin (* Remove_ARPA_comments *) temp_str := str; str := ''; in_comment := false; in_quote := false; escaped := false; for i := 1 to length (temp_str) do begin if (temp_str[i] = '(') and (not in_comment) and (not in_quote) and (not escaped) then in_comment := true; if not in_comment then str := str + temp_str[i]; if (temp_str[i] = ')') and in_comment and (not in_quote) and (not escaped) then in_comment := false; if (temp_str[i] = '"') and (not escaped) then in_quote := not in_quote; if temp_str[i] = '\' then escaped := not escaped else if escaped then escaped := not escaped; end; end; (* Remove_ARPA_comments *) {----------------------------------------------------------------------------- "Parse_VMS_sender" pulls apart VMS sender lines into the actual username (or node::username) part and the personal name field. } procedure Parse_VMS_sender (sender : varying [m1] of char; var addr : varying [m2] of char; var name : varying [m3] of char); var in_quote : boolean; i, end_of_addr, start_of_name : integer; begin (* Parse_VMS_sender *) addr := ''; name := ''; end_of_addr := 0; start_of_name := 0; in_quote := false; for i := 1 to length (sender) do begin if sender[i] = '"' then in_quote := not in_quote else begin if (not in_quote) and (sender[i] = ' ') and (end_of_addr = 0) then end_of_addr := i - 1; if (end_of_addr > 0) and (start_of_name = 0) and in_quote then start_of_name := i; end; end; addr := substr (sender, 1, end_of_addr); if start_of_name > 0 then name := substr (sender, start_of_name, length (sender) - start_of_name); end; (* Parse_VMS_sender *) {------------------------------------------------------------------------------ "Format_header" returns a varying string which is the formatted text of a header. } procedure Format_header (hdr : field_ptr; var str : varying [maxlen] of char); begin (* Format_header *) case hdr^.field_name of fld_continuation : str := ' ' + hdr^.field_body; fld_old_UUCP_from, error_line : str := hdr^.field_body; otherwise str := hdr^.field_name_text + ': ' + hdr^.field_body; end; end; (* Format_header *) {------------------------------------------------------------------------------ "Dispose_header" disposes of a header field. } procedure Dispose_header (var hdr : field_ptr); begin (* Dispose_header *) if hdr^.field_name = fld_from then if hdr^.address <> nil then dispose (hdr^.address); dispose (hdr); hdr := nil; end; (* Dispose_header *) {------------------------------------------------------------------------------ "Read_headers" reads headers from a file into a header structure. We can handle an (essentially) infinite number of headers, since we put them into a linked list. TPARSE should return a syntax error if we scan something that isn't really a header, so we don't have to worry about scanning too far into the message body if there are no headers or if they (illegally) run into the body. One possible problem is that our lines can not be infinitely long. Depending on the mechanism used to read the file, we either truncate or get an error on anything over MESSAGE_LINE_MAX characters long. Should get rid of the Pascal I/O and just use RMS for this. The message may contain headers in several different forms. There may be no headers at all, RFC-822 headers only, UUCP headers only, or UUCP headers followed by RFC-822 headers. The last case is what we'll usually see (from UNIX systems running sendmail or from VMS systems running this code). UUCP only headers may be coming from a System V or old Berkeley UUCP. We have to handle the case of no headers as well, just in case. I doubt we'll ever see only RFC-822 headers, but may as well check for them while we're going through with all this bullshit. To handle this, we have a simple state machine that moves between the states (no_headers, rfc_822_headers, UUCP_headers) based on the kind of header lines we see. The state "rfc_822_headers" is also used for the case where there are UUCP headers as well as RFC-822 style headers. While we are reading them in, spot any "To:", "From:", "From ", and "Subject:" lines for later use, so we can get at them without rescanning the list. The first header we spot of each of these is the one we'll use for that function. By the way, I only bother with leading UUCP lines. Once I see an RFC-822 line, any subsequent UUCP lines are ignored. (wish I could ignore the bloody things completely!) } procedure Read_headers (function Get_line (var line : string) : boolean; var hdrs : header_list_ptr); label 99; var message_line, path, user : string; walker : field_ptr; stat : integer; tpa_block : TPA$TYPE; (* TPARSE block for parsing the headers *) header_field_state, header_field_key : [external, unsafe] integer; from_field_state, from_field_key : [external, unsafe] integer; parsed_field_name_text, parsed_field_body, parsed_field_sp1, parsed_field_sp2 : [external] string_descriptor; parsed_field_name : [external] known_field_names; parser_status : [external] integer; begin (* Read_headers *) new (hdrs); with hdrs^ do begin to_field := nil; from_field := nil; UUCP_from_field := nil; subj_field := nil; first_field := nil; header_type := no_headers; from := ''; remote_name := ''; end; repeat if not Get_line (message_line) then goto 99; if length (message_line) = 0 then goto 99; (* * Now call the parser to pull apart this field. Must clear out the options * field before setting any flags, cause it's full of crap from being allocated * locally (off the stack). TPARSE may fail if we don't do this! (Wasted a * few hours on this one!) *) tpa_block.TPA$L_OPTIONS := 0; tpa_block.TPA$L_COUNT := TPA$K_COUNT0; tpa_block.TPA$V_BLANKS := true; tpa_block.TPA$L_STRINGPTR := iaddress (message_line.body); tpa_block.TPA$L_STRINGCNT := length (message_line); stat := LIB$TPARSE (tpa_block, header_field_state, header_field_key); if hdrs^.first_field = nil then begin new (walker); hdrs^.first_field := walker; end else begin new (walker^.next); walker := walker^.next; end; walker^.next := nil; if odd (stat) then begin walker^.field_name := parsed_field_name; Strdesc_to_varying (parsed_field_name_text, walker^.field_name_text); Strdesc_to_varying (parsed_field_body, walker^.field_body); (* * If we see a continuation line but haven't seen any RFC-822 headers * yet then it's not really a continuation line, so call it an error * line and exit from here just as if we'd seen ann illegal header. *) if (walker^.field_name = fld_continuation) and (hdrs^.header_type <> rfc_822_headers) then begin walker^.field_name := error_line; walker^.field_body := message_line; goto 99; end; if walker^.field_name = fld_old_UUCP_from then case hdrs^.header_type of no_headers : begin hdrs^.header_type := UUCP_headers; hdrs^.UUCP_from_field := walker; Strdesc_to_varying (parsed_field_sp2, path); Strdesc_to_varying (parsed_field_sp1, user); hdrs^.remote_name := path; end; UUCP_headers : begin Strdesc_to_varying (parsed_field_sp2, user); path := path + '!' + user; Strdesc_to_varying (parsed_field_sp1, user); end; rfc_822_headers :; end else begin hdrs^.header_type := rfc_822_headers; case walker^.field_name of fld_from : if hdrs^.from_field = nil then hdrs^.from_field := walker; fld_to : if hdrs^.to_field = nil then hdrs^.to_field := walker; fld_subject : if hdrs^.subj_field = nil then hdrs^.subj_field := walker; otherwise; end; end; end else begin (* * If the line did not parse, then set up the header_type state and exit. * Since UUCP headers are not separated from the text by anything, a parse * error while we're in the UUCP state means we leave the loop but keep * UUCP as our state rather than forcing it to "no_headers" *) walker^.field_name := error_line; walker^.field_body := message_line; if hdrs^.header_type = rfc_822_headers then hdrs^.header_type := no_headers; goto 99; end; until false; 99: (* * Now parse up any field bodies that need extra work. We didn't do * this in the loop above because we have to be able to account for * field bodies with continuation lines. Only ones so far are "From". * * What we do is this: * * First of all, if there were no headers, then wipe out any references * to from, to, and subject headers, since we may have thought we have seen * such lines, only we really didn't... * * If there were no from lines of either type then create a from line saying * "(Cannot determine sender)". * * Now, if there was a RFC-822 from line, parse it to extract the * actual sender address (taking into account continuation fields). * * If there was a UUCP from line, put the system path and the user * together. *) if hdrs^.header_type = no_headers then with hdrs^ do begin to_field := nil; from_field := nil; UUCP_from_field := nil; subj_field := nil; end; if (hdrs^.from_field = nil) and (hdrs^.UUCP_from_field = nil) then hdrs^.from := '(Cannot determine sender)' else begin if hdrs^.from_field <> nil then begin walker := hdrs^.from_field; new (walker^.address); walker^.address^ := walker^.field_body; walker := walker^.next; (* * Unfold continuation lines. Note that we are unfolding into a varying * string with a max length (see type STRING), which could be a source of * error should there be too much text. *) while walker <> nil do if walker^.field_name = fld_continuation then begin hdrs^.from_field^.address^ := hdrs^.from_field^.address^ + ' ' + walker^.field_body; walker := walker^.next; end else walker := nil; (* * Now we've got the address unfolded. Parse it for the "< ... >" form. *) tpa_block.TPA$L_COUNT := TPA$K_COUNT0; tpa_block.TPA$V_BLANKS := true; tpa_block.TPA$L_STRINGPTR := iaddress(hdrs^.from_field^.address^.body); tpa_block.TPA$L_STRINGCNT := length (hdrs^.from_field^.address^); stat := LIB$TPARSE (tpa_block, from_field_state, from_field_key); if odd (stat) and (parser_status = 0) then begin Strdesc_to_varying(parsed_field_body,hdrs^.from_field^.address^); Remove_ARPA_comments (hdrs^.from_field^.address^); Trim_trailing_blanks (hdrs^.from_field^.address^); Trim_leading_blanks (hdrs^.from_field^.address^); end else hdrs^.from_field^.address^ := '(Bad address in "From:" field)'; hdrs^.from := hdrs^.from_field^.address^; end; if hdrs^.UUCP_from_field <> nil then begin hdrs^.from := path + '!' + user; end; end; end; (* Read_headers *) {------------------------------------------------------------------------------ "Create_with_SYSPRV" is a Pascal user-action routine for the OPEN statement. It enables SYSPRV while doing certain OPEN's so we can get at special directories. } function Create_with_SYSPRV (var fab : FAB$TYPE; var rab : RAB$TYPE; var fil : text) : integer; var stat : integer; priv : [quad] array [0..1] of unsigned; begin (* Create_with_SYSPRV *) priv[0] := PRV$M_SYSPRV; priv[1] := 0; stat := $SETPRV (ENBFLG := 1, PRVADR := priv, PRMFLG := 0); if odd (stat) then begin FAB.FAB$V_LNM_MODE := PSL$C_EXEC; stat := $CREATE (FAB); if odd (stat) then stat := $CONNECT (RAB); $SETPRV (ENBFLG := 0, PRVADR := priv, PRMFLG := 0); end; Create_with_SYSPRV := stat; end; (* Create_with_SYSPRV *) {------------------------------------------------------------------------------ The following [global] routines are called by MAIL through the MAILSHR dispatcher. } [global] function MAIL_OUT_CONNECT (var context : message_info_ptr; var link_flag : integer; var protocol, node : string_descriptor; var log_link_error : integer; var file_RAT, file_RFM : integer; var MAIL$GL_FLAGS : integer; var attached_file : string_descriptor ) : integer; begin (* MAIL_OUT_CONNECT *) new (context); context^.addresses := nil; context^.to_line := ''; context^.subject_line := ''; context^.personal_name := ''; context^.headers := nil; MAIL_OUT_CONNECT := SS$_NORMAL; end; (* MAIL_OUT_CONNECT *) [global] function MAIL_OUT_LINE (var context : message_info_ptr; var link_flag : integer; var node, line : string_descriptor ) : integer; var stat : integer; text_line : string; begin (* MAIL_OUT_LINE *) stat := Strdesc_to_varying (line, text_line); (* * If the sender begins with "UUCP%", it means our _IN_ code * got the message originally from RMAIL and stuck the "UUCP%" * on so that a VMS MAIL user can REPLY to the message. Since * we got here, however, we are just routing the message through * to another system and need to strip the "UUCP%" back off. * * The next thing to do is pull out the VMS personal name field * and put it into a separate string. This is so that it can be * incorporated into the new RFC-822 headers in the proper way. * *) case iaddress (link_flag) of LNK_C_OUT_TO : context^.to_line := text_line; LNK_C_OUT_SENDER : if Begins_with (text_line, 'UUCP%') then begin context^.from_line := substr (text_line, 7, length (text_line) - 7); context^.personal_name := ''; end else Parse_VMS_sender (text_line, context^.from_line, context^.personal_name); LNK_C_OUT_SUBJ : context^.subject_line := text_line; end; MAIL_OUT_LINE := SS$_NORMAL; end; (* MAIL_OUT_LINE *) [global] function MAIL_OUT_CHECK (var context : message_info_ptr; var link_flag : integer; var protocol, addressee : string_descriptor; procedure MAIL$READ_ERROR_TEXT ) : integer; var stat : integer; addressee_str : string; temp : addr_list_ptr; begin (* MAIL_OUT_CHECK *) stat := Strdesc_to_varying (addressee, addressee_str); case iaddress (link_flag) of LNK_C_OUT_CKUSER:begin if not Strings_are_equal (addressee_str, null_byte) then if valid_address (addressee_str) then begin new (temp); with temp^ do begin name := addressee_str; next := context^.addresses; extension := Make_unique_name; end; context^.addresses := temp; MAIL_OUT_CHECK := SS$_NORMAL; end else begin LIB$SIGNAL (iaddress (UUCP$_BADADDR)); MAIL_OUT_CHECK := iaddress (UUCP$_BADADDR); end; end; LNK_C_OUT_CKSEND:begin open (FILE_VARIABLE := context^.requests_file, FILE_NAME := 'UUCP_REQUESTS', HISTORY := old); rewrite (context^.requests_file); temp := context^.addresses; if temp = nil then LIB$SIGNAL (iaddress (UUCP$_INTCODERR), 0, iaddress (UUCP$_NILADRFND)); writeln (context^.requests_file,'@UUCP_ROOT:[LIB]DO ', temp_dir, 'UUCP_COMMAND.', temp^.extension, '; "@SYS$INPUT" D'); context^.addresses := temp^.next; dispose (temp); temp := nil; close (context^.requests_file); MAIL_OUT_CHECK := SS$_NORMAL; end; end; end; (* MAIL_OUT_CHECK *) [global] function MAIL_OUT_FILE (var context : message_info_ptr; var link_flag : integer; var protocol : string_descriptor; var mail_RAB : RAB$TYPE; [asynchronous, unbound] procedure UTIL$REPORT_ERROR ) : integer; var message_line, message_file_name, cmd_file_name : string; UUCP_host_name : string; stat, delimiter : integer; temp : addr_list_ptr; date_time : short_string; walker, prev : field_ptr; done : boolean; message_RAB : RAB$TYPE; default_RAB : [external, readonly] RAB$TYPE; function Get_line (var line : string) : boolean; begin (* Get_line *) Get_line := false; message_RAB.RAB$L_UBF := iaddress (line.body); message_RAB.RAB$W_USZ := message_line_max; stat := $GET (RAB := message_RAB); if odd (stat) then begin line.length := message_RAB.RAB$W_RSZ; Get_line := true; end else if stat <> RMS$_EOF then LIB$SIGNAL (SS$_ACCVIO); (* Force a process DUMP to debug this bastard *) { LIB$SIGNAL (iaddress(UUCP$_MESFILERR), 0, stat); } end; (* Get_line *) begin (* MAIL_OUT_FILE *) if mail_RAB.RAB$V_BIO then begin message_RAB := default_RAB; message_RAB.RAB$L_FAB := mail_RAB.RAB$L_FAB; stat := $CONNECT (RAB := message_RAB); if not odd (stat) then LIB$SIGNAL (iaddress(UUCP$_MESFILERR), 0, stat); end else message_RAB := mail_RAB; date_time := ARPA_date_time; LIB$SYS_TRNLOG ('UUCP_HOST_NAME', , UUCP_host_name); temp := context^.addresses; while temp <> nil do begin message_file_name := temp_dir + 'UUCP_MESSAGE.' + temp^.extension + ';'; cmd_file_name := temp_dir + 'UUCP_COMMAND.' + temp^.extension + ';'; open (FILE_VARIABLE := temp^.message_file, FILE_NAME := message_file_name, HISTORY := new, USER_ACTION := Create_with_SYSPRV); rewrite (temp^.message_file); (* Here's where we handle message headers in outgoing messages. * * We will try to use RFC 822 style headers. However, for now I am * not using very many of them (just a few more than the required subset). * In addition, we have to add (to the very top) an old-style UUCP * "From ... remote from ..." line for non-internet capable UUCP mail * recipients. * * First see if there are any headers in the incoming text. If so, then * we are probably routing a message through here (or someone wanted to * put their own headers into the file). If not, then build some default * headers from scratch. Note that if we are routing a message through * here then our _IN_ code has been run. If this is the case, then the * _IN_ code has put a "Received:" header line in the message, whether * or not the message originally had RFC-822 headers. Since this code * sees the "Received:" line it'll think the message has headers even if * it came from a system which did not make headers. This cleverly causes * the code here to NOT make up headers on files being routed through, even * if they didn't come with headers originally. * * In any case, whatever "From" information comes out of the headers is * overridden by the "From" address we were given by MAIL. This is so * people cannot forge the from address. * * Note: When I make up my own "To:" line, I put the address that I think * this message is going to in it. This is because I know that is * a legal address. The "To" line that VMS MAIL hands me is simply * what the user typed, and may be an indirect file, logical name, * or who-knows-what. I cannot put that into the "To:" line because * some mailers who receive this message may want to parse that for * replies. Hence, I am making up my own header field called * "X-VMS-Mail-To:" * *) Read_headers (Get_line, context^.headers); context^.headers^.from := context^.from_line; if context^.headers^.header_type in [no_headers, UUCP_headers] then begin new (walker); (* Blank line *) with walker^ do begin field_name := error_line; field_body := ''; field_name_text := ''; next := context^.headers^.first_field; end; context^.headers^.first_field := walker; if length (context^.to_line) > 0 then begin new (walker); (* X-VMS-Mail-To *) with walker^ do begin field_name := fld_unknown; field_body := context^.to_line; field_name_text := 'X-VMS-Mail-To'; next := context^.headers^.first_field; end; context^.headers^.first_field := walker; end; new (walker); (* To *) with walker^ do begin field_name := fld_to; field_body := temp^.name; field_name_text := 'To'; next := context^.headers^.first_field; end; context^.headers^.to_field := walker; context^.headers^.first_field := walker; new (walker); (* Subject *) with walker^ do begin field_name := fld_subject; field_body := context^.subject_line; field_name_text := 'Subject'; next := context^.headers^.first_field; end; context^.headers^.subj_field := walker; context^.headers^.first_field := walker; new (walker); (* From *) with walker^ do begin field_name := fld_from; new (address); address^ := context^.headers^.from; field_body := context^.personal_name + ' <' + address^ + '>'; field_name_text := 'From'; next := context^.headers^.first_field; end; context^.headers^.from_field := walker; context^.headers^.first_field := walker; new (walker); (* Date *) with walker^ do begin field_name := fld_date; field_body := date_time; field_name_text := 'Date'; next := context^.headers^.first_field; end; context^.headers^.first_field := walker; end; (* * Now we mangle the headers to indicate that the message is being sent * out from this system. At this point it matters not whether the headers * we are mangling were built in the code right above or are something the * message came into our system with. We do the following: * * - Strip out all OLD_UUCP_FROM headers. * - Edit the "From" address fields a little to tack our UUCP_HOST_NAME * on the front. *) with context^.headers^ do begin done := first_field = nil; while not done do begin if first_field^.field_name = fld_old_UUCP_from then begin walker := first_field; first_field := walker^.next; Dispose_header (walker); done := first_field = nil; end else done := true; end; if first_field <> nil then begin walker := first_field^.next; prev := first_field; while walker <> nil do begin if walker^.field_name = fld_old_UUCP_from then begin prev^.next := walker^.next; dispose (walker); end else prev := walker; walker := prev^.next; end; end; if from_field <> nil then if from_field^.address <> nil then begin Replace_string (from_field^.field_body, from_field^.address^, UUCP_host_name + '!' + context^.headers^.from); from_field^.address^ := UUCP_host_name + '!' + context^.headers^.from; end; end; (* Build a command file to be executed by the UUCP demon. *) open (FILE_VARIABLE := temp^.cmd_file, FILE_NAME := cmd_file_name, HISTORY := new, USER_ACTION := Create_with_SYSPRV); rewrite (temp^.cmd_file); writeln (temp^.cmd_file, '$ define/user SYS$INPUT ', message_file_name); delimiter := Index (temp^.name, '!'); writeln (temp^.cmd_file, '$ uux "-" "', Substr (temp^.name, 1, delimiter), 'rmail" "(', Substr (temp^.name, delimiter + 1, length (temp^.name) - delimiter), ')"'); writeln (temp^.cmd_file, '$ delete ', message_file_name); close (temp^.cmd_file); temp := temp^.next; end; (* * Lead with a UUCP header. *) temp := context^.addresses; while temp <> nil do begin writeln (temp^.message_file, 'From ', context^.headers^.from, ' ', date_time, ' remote from ', UUCP_host_name); temp := temp^.next; end; (* * Then put out the headers. *) walker := context^.headers^.first_field; while walker <> nil do begin Format_header (walker, message_line); temp := context^.addresses; while temp <> nil do begin writeln (temp^.message_file, message_line); temp := temp^.next; end; walker := walker^.next; end; (* * If the message began with RFC-822 headers, then we need a blank line. *) if context^.headers^.header_type = rfc_822_headers then begin temp := context^.addresses; while temp <> nil do begin writeln (temp^.message_file); temp := temp^.next; end; end; (* * Now copy over the body of the message. *) message_RAB.RAB$L_UBF := iaddress (message_line.body); message_RAB.RAB$W_USZ := message_line_max; repeat stat := $GET (RAB := message_RAB); if odd (stat) then begin message_line.length := message_RAB.RAB$W_RSZ; temp := context^.addresses; while temp <> nil do begin writeln (temp^.message_file, message_line); temp := temp^.next; end; end; until not odd (stat); if stat <> RMS$_EOF then begin LIB$SIGNAL (iaddress(UUCP$_MESFILERR), 0, stat); MAIL_OUT_FILE := iaddress (UUCP$_MESFILERR); end else MAIL_OUT_FILE := SS$_NORMAL; temp := context^.addresses; while temp <> nil do begin close (temp^.message_file); temp := temp^.next; end; end; (* MAIL_OUT_FILE *) [global] function MAIL_OUT_DEACCESS (var context : message_info_ptr; var link_flag : integer ) : integer; var temp : addr_list_ptr; temp_h : field_ptr; begin (* MAIL_OUT_DEACCESS *) temp := context^.addresses; while temp <> nil do begin context^.addresses := temp^.next; dispose (temp); temp := context^.addresses; end; if context^.headers <> nil then begin temp_h := context^.headers^.first_field; while temp_h <> nil do begin context^.headers^.first_field := temp_h^.next; dispose_header (temp_h); temp_h := context^.headers^.first_field; end; dispose (context^.headers); context^.headers := nil; end; dispose (context); context := nil; MAIL_OUT_DEACCESS := SS$_NORMAL; end; (* MAIL_OUT_DEACCESS *) {----------------------------------------------------------------------------- These routines manipulate a stack in which we maintain state information for information being "written" to us when MAIL calls MAIL_IO_WRITE. } procedure Init_stack (var stack : write_state_stack); begin (* Init_stack *) stack.top := 0; end; (* Init_stack *) procedure Push (var stack : write_state_stack; state : write_states); var i : integer; begin (* Push *) with stack do begin top := top + 1; if top > stack_size then LIB$SIGNAL (iaddress (UUCP$_INTCODERR), 0, iaddress (UUCP$_STKOVRFLO)); store[top] := state; end; if DEBUG_ON then begin writeln ('after PUSH:'); for i := stack.top downto 1 do writeln (stack.store[i]); end; end; (* Push *) procedure Pop (var stack : write_state_stack); var i : integer; begin (* Pop *) with stack do begin top := top - 1; if top < 1 then LIB$SIGNAL (iaddress (UUCP$_INTCODERR), 0, iaddress (UUCP$_STKEMPTY)); end; if DEBUG_ON then begin writeln ('after POP:'); for i := stack.top downto 1 do writeln (stack.store[i]); end; end; (* Pop *) function Top_of_stack (var stack : write_state_stack) : write_states; begin (* Top_of_stack *) Top_of_stack := stack.store[stack.top]; end; (* Top_of_stack *) [global] function MAIL_IN_CONNECT (var context : message_info_ptr; var link_flag : integer; var input_tran : string_descriptor; var file_RAT, file_RFM : integer; var MAIL$GL_SYSFLAGS : integer; var MAIL$Q_PROTOCOL : string_descriptor; var pflags : integer ) : integer; var recipient : string; tmp : addr_list_ptr; stat : integer; UUCP_host_name : string; date_time : short_string; walker, prev : field_ptr; done : boolean; (* * Local function to pass to "Read_headers" so's it can read lines... *) function Get_line (var line : string) : boolean; begin (* Get_line *) Get_line := false; if not EOF (context^.message_text) then begin readln (context^.message_text, line); Get_line := true; end; end; (* Get_line *) begin (* MAIL_IN_CONNECT *) if DEBUG_ON then writeln ('MAIL_IN_CONNECT called'); date_time := ARPA_date_time; LIB$SYS_TRNLOG ('UUCP_HOST_NAME', , UUCP_host_name); new (context); context^.addresses := nil; context^.to_line := ''; context^.subject_line := ''; context^.personal_name := ''; context^.headers := nil; { Initialize state machine for IO_WRITE messages } init_stack (context^.write_recv_states); push (context^.write_recv_states, unexpected_message); { Parse command line and retrieve recipients and message text file } context^.addresses := nil; repeat stat := CLI$GET_VALUE ('TOLIST', recipient); if stat <> iaddress (CLI$_ABSENT) then if not odd (stat) then LIB$SIGNAL (stat) else begin new (tmp); tmp^.next := context^.addresses; tmp^.name := recipient; context^.addresses := tmp; end; until stat = iaddress (CLI$_ABSENT); if context^.addresses = nil then LIB$SIGNAL (iaddress (UUCP$_NORECIP)); stat := CLI$GET_VALUE ('FILE', context^.message_file); if not odd (stat) then LIB$SIGNAL (iaddress(UUCP$_GETFILERR), 0, stat); (* * Now open the file and parse the headers. *) Open (FILE_VARIABLE := context^.message_text, FILE_NAME := context^.message_file, HISTORY := OLD); Reset (context^.message_text); Read_headers (Get_line, context^.headers); if DEBUG_ON then DEBUG_dump_headers (context^.headers); (* * Now we munge the incoming headers just a little bit. * - Remove all UUCP headers, they just get in the way... * - Add a "Received-by:" header to show the message came through us. *) with context^.headers^ do begin done := first_field = nil; while not done do begin if first_field^.field_name = fld_old_UUCP_from then begin walker := first_field; first_field := walker^.next; Dispose_header (walker); done := first_field = nil; end else done := true; end; if first_field <> nil then begin walker := first_field^.next; prev := first_field; while walker <> nil do begin if walker^.field_name = fld_old_UUCP_from then begin prev^.next := walker^.next; dispose (walker); end else prev := walker; walker := prev^.next; end; end; if context^.headers^.header_type <> rfc_822_headers then begin new (walker); with walker^ do begin field_name := error_line; field_body := ''; field_name_text := ''; next := context^.headers^.first_field; end; context^.headers^.first_field := walker; end; new (walker); (* add "Received" with continue line *) with walker^ do begin field_name := fld_continuation; field_body := date_time; field_name_text := ''; next := context^.headers^.first_field; end; context^.headers^.first_field := walker; new (walker); with walker^ do begin field_name := fld_received; field_body := 'by ' + UUCP_host_name + '.UUCP with VMS/UUCP;'; if length (context^.headers^.remote_name) > 0 then field_body := 'from ' + remote_name + '.UUCP ' + field_body; field_name_text := 'Received'; next := context^.headers^.first_field; end; context^.headers^.first_field := walker; end; if DEBUG_ON then DEBUG_dump_headers (context^.headers); MAIL_IN_CONNECT := SS$_NORMAL; end; (* MAIL_IN_CONNECT *) [global] function MAIL_IN_LINE (var context : message_info_ptr; var link_flag : integer; var line : string_descriptor ) : integer; var tmp : addr_list_ptr; stat : integer; text_line, temp_line : string; begin (* MAIL_IN_LINE *) if DEBUG_ON then writeln ('MAIL_IN_LINE called with LNK = ', iaddress (link_flag)); case iaddress (link_flag) of LNK_C_IN_SENDER: begin text_line := 'UUCP%"' + context^.headers^.from + '"'; if DEBUG_ON then begin writeln ('This message from:'); writeln ('|', text_line, '|'); end; end; LNK_C_IN_CKUSER: begin with context^ do if addresses = nil then text_line := null_byte else begin text_line := addresses^.name; if DEBUG_ON then begin writeln ('This message to:'); writeln ('|', text_line, '|'); end; tmp := addresses; addresses := tmp^.next; dispose (tmp); tmp := nil; push (context^.write_recv_states, user_check); end; end; LNK_C_IN_TO : begin text_line := ''; if context^.headers <> nil then if context^.headers^.to_field <> nil then text_line := context^.headers^.to_field^.field_body; if DEBUG_ON then begin writeln ('This message "To" line:'); writeln ('|', text_line, '|'); end; end; LNK_C_IN_SUBJ : begin text_line := ''; if context^.headers <> nil then if context^.headers^.subj_field <> nil then text_line := context^.headers^.subj_field^.field_body; if DEBUG_ON then begin writeln ('This message "Subject" line:'); writeln ('|', text_line, '|'); end; end; end; stat := Varying_to_strdesc (text_line, line); MAIL_IN_LINE := stat; end; (* MAIL_IN_LINE *) [global] function MAIL_IN_FILE (var context : message_info_ptr; var link_flag : integer; var scratch : integer; var RAB : RAB$TYPE; procedure UTIL$REPORT_IO_ERROR ) : integer; var stat : integer; message_line : string; walker : field_ptr; begin (* MAIL_IN_FILE *) if DEBUG_ON then writeln ('MAIL_IN_FILE called with LNK = ', iaddress (link_flag)); (* * First put out the headers. *) walker := context^.headers^.first_field; while walker <> nil do begin Format_header (walker, message_line); RAB.RAB$L_RBF := iaddress (message_line.body); RAB.RAB$W_RSZ := length (message_line); stat := $PUT (RAB := RAB); if not odd (stat) then LIB$SIGNAL (iaddress (UUCP$_MSGWRTERR), 0, stat); walker := walker^.next; end; (* * Headers separated from body with a blank line. *) if context^.headers^.header_type = rfc_822_headers then begin RAB.RAB$W_RSZ := 0; stat := $PUT (RAB := RAB); if not odd (stat) then LIB$SIGNAL (iaddress (UUCP$_MSGWRTERR), 0, stat); end; (* * Now copy over the body of the message. *) RAB.RAB$L_RBF := iaddress (message_line.body); while not EOF (context^.message_text) do begin readln (context^.message_text, message_line); RAB.RAB$W_RSZ := length (message_line); stat := $PUT (RAB := RAB); if not odd (stat) then LIB$SIGNAL (iaddress (UUCP$_MSGWRTERR), 0, stat); end; close (context^.message_text); push (context^.write_recv_states, delivery_check); MAIL_IN_FILE := 1; end; (* MAIL_IN_FILE *) [global] function MAIL_IO_WRITE (var context : message_info_ptr; var link_flag : integer; line : string_descriptor ) : integer; var text_line : string; stat : integer; begin (* MAIL_IO_WRITE *) if DEBUG_ON then writeln ('MAIL_IO_WRITE called with LNK = ', iaddress (link_flag)); Strdesc_to_varying (line, text_line); case Top_of_stack (context^.write_recv_states) of delivery_check : begin stat := String_to_integer (text_line); if DEBUG_ON then writeln (' got a stat : ', stat); if stat <> SS$_NORMAL then push (context^.write_recv_states, error_text_expected); end; user_check : begin stat := String_to_integer (text_line); if DEBUG_ON then writeln (' got a stat : ', stat); pop (context^.write_recv_states); if stat <> SS$_NORMAL then push (context^.write_recv_states, error_text_expected); end; error_text_expected : begin if Strings_are_equal (text_line, null_byte) then begin if DEBUG_ON then writeln (' got a NULL_BYTE -- popping write_recv_states'); pop (context^.write_recv_states) end else begin if DEBUG_ON then writeln (' got a message : ', text_line); end; end; unexpected_message : begin stat := String_to_integer (text_line); if DEBUG_ON then writeln (' UNEXPECTED stat : ', stat); push (context^.write_recv_states, error_text_expected); end; otherwise LIB$SIGNAL (iaddress (UUCP$_INTCODERR), 0, iaddress (UUCP$_BADSTATE)); end; MAIL_IO_WRITE := 1; end; (* MAIL_IO_WRITE *) [global] function MAIL_IO_READ (var context : message_info_ptr; var link_flag : integer; var returned_line : string_descriptor ) : integer; var text_line : string; begin (* MAIL_IO_READ *) if DEBUG_ON then writeln ('MAIL_IO_READ called with LNK = ', iaddress (link_flag)); Varying_to_strdesc (text_line, returned_line); MAIL_IO_READ := 1; end; (* MAIL_IO_READ *) end. (* UUCP_mail *)