# -*-Perl-*-
################################################################
###
###			      Message.pm
###
###	      Copyright (C) 1997  Internet Message Group
###
###		     This Perl5 library conforms
###		GNU GENERAL PUBLIC LICENSE Version 2.
###
###
### Author:  Internet Message Group <img@mew.org>
### Created: Apr 23, 1997
### Revised: @im_revised@
###

my $PM_VERSION = "IM::Message.pm @im_version@";

package IM::Message;
require 5.003;
require Exporter;

use IM::Util;
use IM::Address qw(extract_addr replace_addr fetch_addr);
use IM::Alias qw(alias_lookup alias_host_completion);
use IM::Header qw(gen_message_id gen_date header_value add_header hdr_cat);
use integer;
use strict;
use vars qw(@ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw(
	read_header
	message_size
	put_header
	read_body
	put_body

	rewrite_header
	rewrite_resend_header
	body_qp_encode
	body_base64_encode
	put_mimed_bcc
	put_mimed_partial
	put_mimed_error_notify
	set_crlf
	crlf
);

=head1 NAME

Message - IM Message

=head1 SYNOPSIS

=head1 DESCRIPTION

=cut

use vars qw($First_body_line $First_part_mid
	    $bcc_mid $crlf_char);

##### READ HEADER #####
#
# read_header(channel, header, dist_append_flag)
#	channel: socket/file descriptor to write out
#	dist_append_flag: as redistribution headers if true
#	return value:
#	  0: success
#	 -1: failure
#
sub read_header (*$$) {
    local *CHAN = shift;
    my ($Header, $dist_append) = @_;
    my ($inheader, $line) = (1, '');

    $First_body_line = '';
    local $_ = <CHAN>;
    unless ($_) {
	$inheader = 0;
	$First_body_line = '' unless ($dist_append);
    } elsif (!$main::Smtp_input_mode && $_ =~ /^From /) {
	$_ = <CHAN>;		# skip UNIX From_ line
    }
    while ($inheader) {
	$line = $_;
	if ($main::Draft_message && $line =~ /^-+$/) {
	    $inheader = 0;
	    $First_body_line = "\n" unless ($dist_append);
	    $line = '';
	    last;
	}
	if ($line !~ /^[\w-]+:/) {
	    $inheader = 0;
	    $First_body_line = $line unless ($dist_append);
	    $line = '';
	    last;
	}
	if ($dist_append) {
	    if ($line !~ /^Resent-(To|Cc|Bcc|Dcc|Fcc|Reply-To|Sender|From):/i) {
		$line =~ /^([\w-]+:)/;
		im_err("Remove $1 from re-send information.\n");
		return -1;
	    }
	}
	while (<CHAN>) {
	    if (/^[ \t]/) {
		    $line .= $_;
	    } else {
		    last;
	    }
	}
	push (@$Header, $line) if ($line);
    }
    return 0;
}

##### REWRITE HEADER ON ADDRESSES #####
#
# rewrite_header(header)
#	header: reference to a message header array
#	return value:
#	  -1: failed
#	   0: success
#
sub rewrite_header ($) {
    my $Header = shift;
    my ($i, $val);
    local $_;

    my $e = $#$Header;	# do not evaluate in the loop
    for ($i = 0; $i <= $e; $i++) {
	$_ = $$Header[$i];
	if (/^(Resent-)?(To|Cc|Bcc|Dcc):\s*(.*)/is) {
	    &add_header($Header, 0, " ORIGINAL $1$2: ", $3);
	    $val = &rewrite_addr_list($Header, 0, $3, !$main::Obey_MTA_domain);
	    return -1 if ($val eq '');
	    $$Header[$i] = "$1$2: $val";
	} elsif (/^(Resent-)?(From|Reply-To|Errors-To|Return-Receipt-To):\s*(.*)/is) {
	    &add_header($Header, 0, " ORIGINAL $1$2: ", $3);
	    $val = &rewrite_addr_list($Header, 1, $3, !$main::Obey_MTA_domain);
	    return -1 if ($val eq '');
	    $$Header[$i] = "$1$2: $val";
	} elsif (/^(B?Newsgroups):(.*)/is) {
	    # strip spaces off
	    my $fieldname = $1;
	    ($val = $2) =~ s/[ \t]//g;
	    $$Header[$i] = "$fieldname: $val";
	} elsif (/^([\w-]+):\s*(\S.*)/s) {
	    $$Header[$i] = "$1: $2";
	}
    }
    return 0;
}

##### REWRITE ADDRESS LIST #####
#
# rewrite_addr_list(header, sender_flag, address_list, append_default)
#	header: reference to a message header array
#	sender_flag: rewrite as a sender's address
#	address_list: address list to be rewrited
#	append_default: append default domain name for local names if true
#	return value: rewritten addresses (NULL if error)
#
sub rewrite_addr_list ($$$;$) {
    my ($Header, $sender_flag, $addr_list, $def_append) = @_;
    my ($line, $ret, $addr, $a, $b, $err);

    $addr_list =~ s/^\s+//;
    $addr_list =~ s/\s+$//;
#   $addr_list =~ s/\n[ \t]+/ /g;	# XXX
    while ($addr_list ne '') {
	($addr, $addr_list) = &fetch_addr($addr_list, 0);
	return '' if ($addr eq '');
	$a = &extract_addr($addr);
	if ($a =~ /^(.+)(:[^;]*;)$/) {	# YYY
#	    &expn_group(0, "$1$2");
	    &add_header($Header, 0, $main::Resend_prefix.'Dcc', "$1$2");
	    $addr = "$1:;";
	} else {
	    if ($addr =~ /^\@MYSELF\@/i || $addr =~ /^\@ME\@/i) {
		$addr = $main::Sender;
	    }
	    if ($a !~ /[\@%!:]/ && ($b = &alias_lookup($a)) ne '') {
## if ISO2022JP
		if ($main::Iso2022jp_code_conversion) {
		    require IM::Japanese;
		    import IM::Japanese qw(conv_iso2022jp);

		    $b = &conv_iso2022jp($b);
		}
		if ($main::Iso2022jp_header_mime_conv) {
		    require IM::Iso2022jp;
		    import IM::Iso2022jp qw(struct_iso2022jp_mimefy);

		    my $bb = &struct_iso2022jp_mimefy($b);
		    $b = $bb if ($bb ne '');
		}
## endif
		if ($addr_list) {
		    $addr_list = "$b,$addr_list";
		} else {
			$addr_list = $b;
		}
		next;
	    }
	    if ($a !~ /[\@%!:]/o) {
		if ($sender_flag && $def_append
		    && $main::Default_from_domain_name) {
		    $b = "$a\@$main::Default_from_domain_name";
		    $addr = &replace_addr($addr, $a, $b);
		} elsif ($def_append && $main::Default_to_domain_name) {
		    $b = "$a\@$main::Default_to_domain_name";
		    $addr = &replace_addr($addr, $a, $b);
		}
	    } elsif ($b = alias_host_completion($a)) {
		$addr = &replace_addr($addr, $a, $b);
	    }
	}
	$line .= ',' if ($line);
	im_debug("rewrite: $a => $addr\n") if (&debug('alias'));
	$line = &hdr_cat($line, $addr, 'any');
	$addr_list =~ s/^\s*//;
    }
    return "$line\n";
}

##### REWRITE HEADER FOR RESEND #####
#
# rewrite_resend_header()
#	return value: none
#
sub rewrite_resend_header ($) {
    my $Header = shift;

    my $i;
    for ($i = 0; $i <= $#$Header; $i++) {
	if ($$Header[$i] =~ /^Resent-/i) {
	    $$Header[$i] = "Prev-$$Header[$i]";
	}
    }
}

##### PUT HEADER TO SMTP CHANNEL #####
#
# put_header(channel, header, protocol, field_selection)
#	channel: socket/file descriptor to write out
#	field_selection: ext/int header specification in partial message mode
#	protocol:
#	return value:
#		 0: success
#		-1: failure
#
sub put_header (*$$$) {
    local *CHAN = shift;
    my ($Header, $proto, $sel) = @_;
    my ($line, $del, $s);
    my $crlf = &crlf;

    im_debug("entering put_header\n")
      if (&debug('header') || &debug('put'));
    hdr: foreach $line (@$Header) {
	next if ($line =~ /^ KILLED /);
	if ($line =~ /^ ORIGINAL /) {
	    next if ($sel ne 'original');
	    if ($line =~ /^ ORIGINAL Dcc:/i) {
		$line =~ s/^ ORIGINAL //;
	    } else {
		next;
	    }
	}
	if ($sel =~ /^partial:/) {
	    if ($line =~ /^(Mime-Version|Message-Id|Encrypted|Lines):/i
	     || $line =~ /^Content-/i) {
		next if ($sel =~ /:ext$/);
	    } else {
		next if ($sel =~ /:int$/);
	    }
	}
	if ($proto =~ /smtp/i) {
	    foreach $del (@main::Del_headers_on_mail) {
		next hdr if ($line =~ /^$del:/i);
	    }
	    next if ($line =~ /^BNewsgroups:/i);
	    $line =~ s/^Newsgroups:/X-Newsgroups:/i;
	}
	if ($proto =~ /nntp/i) {
	    foreach $del (@main::Del_headers_on_news) {
		next hdr if ($line =~ /^$del:/i);
	    }
	    next hdr if ($line =~ /Message-Id:/i && $main::NoMsgIdForNews);
	    if ($main::Obey_MTA_domain
	      && ($line =~ /^(From|Sender|Reply-To):\s*(.*)/i)) {
		my $val = &rewrite_addr_list($Header, 1, $2, 1);
		return -1 if ($val eq '');
		$line = "$1: $val";
	    }
	    $line =~ s/^Sender:/Originator:/i;
	    $line =~ s/^BNewsgroups:/Newsgroups:/i;
	}
	$line .= "\n" if ($line !~ /\n$/);
	$line =~ s/\r?\n/\r\n/g if ($crlf eq "\r\n");
	im_debug("|$line") if (&debug('header') || &debug('put'));
	    return -1 unless (print CHAN "$line");
    }
    if ($proto =~ /nntp/i && !&header_value($Header, 'Path')) {
#	return -1 unless (print CHAN "Path: $main::Login$crlf");
	return -1 unless (print CHAN "Path: not-for-mail$crlf");
    }
    im_debug("put_header finished: no error\n")
      if (&debug('header') || &debug('put'));
    return 0;
}

##### READ BODY #####
#
# read_body(channel, body, hidden_dot, term_dot)
#	channel: socket/file descriptor to write out
#	hidden_dot: hidden dot algorithm is used if true
#	term_dot: terminating dot protocol is used if true
#	return value: none
#
sub read_body (*$$$) {
    local *CHAN = shift;
    my ($Body, $hidden_dot, $term_dot) = @_;
    local $_;
    @$Body = ();

    if ($hidden_dot || $term_dot) {
	return if ($First_body_line =~ /^\.[\r\n]/);
	$First_body_line =~ s/^\.\././ if ($hidden_dot);
    }
    if ($First_body_line) {
	if ($First_body_line ne "\n") {
	    push (@$Body, "\n");
	}
	push (@$Body, $First_body_line);
	while (<CHAN>) {
	    if ($hidden_dot || $term_dot) {
		last if (/^\.[\r\n]/);
		s/^\.\././ if ($hidden_dot);
	    }
	    push (@$Body, $_);
	}
	$First_body_line = "\n";	# XXX
    }
}

##### CONVERT BODY INTO QUOTED-PRINTABLE ENCODING #####
#
# body_qp_encode(Body)
#	content: pointer to body content line list
#	return value: none
#
sub body_qp_encode ($) {
    my $Body = shift;
    my ($i, $line, $pos);

    for ($i = 0; $i <= $#$Body; $i++) {
	$line = $$Body[$i];
	$line .= "\n" if ($line !~ /\n$/);	# XXX
	$line =~ s/([\000-\010\013-\037=\177-\377])/sprintf("=%02X", unpack ("C", $1))/ge;
	$line =~ s/ \n$/=20\n/;
	$line =~ s/\t\n$/=09\n/;
	$line =~ s/^\.\n$/=2e\n/;
	$line =~ s/^From /From=20/;
	while (!$main::NoFolding && (length($line) > $main::Folding_length+3)) {
	    # XXX line splitting
	    for ($pos = $main::Folding_length; $pos < $main::Folding_length+3;
	      $pos++) {
		last if (substr($line, $pos, 1) eq "=");
	    }
	    (my $tmp, $line) = unpack("a$pos a*", $line);
	    splice(@$Body, $i, 0, $tmp . "=");
	    $i++;
	}
	$$Body[$i] = $line;
    }
}

##### CONVERT BODY INTO BASE64 ENCODING #####
#
# body_base64_encode(content)
#	content: pointer to body content line list
#	return value: none
#
sub body_base64_encode ($) {
    my $Body = shift;
    my $line = '';
    my ($i, $tmp, @Body_tmp);

    require IM::EncDec && import IM::EncDec qw(b_encode_string);

    for ($i = 0; $i <= $#$Body; $i++) {
	$line .= $$Body[$i];
	$line .= "\n" if ($line !~ /\n$/);
#	$line =~ s/\r?\n?$/\r\n/;
	next if (length($line) < 54 && $i <= $#$Body);
	($tmp, $line) = unpack('a54 a*', $line);
	push(@Body_tmp, &b_encode_string($tmp));
    }
    while ($line ne '') {
	($tmp, $line) = unpack('a54 a*', $line);
	push(@Body_tmp, &b_encode_string($tmp));
    }
    @$Body = @Body_tmp;
    @Body_tmp = ();	# XXX
}

##### PUT BODY TO SMTP CHANNEL #####
#
# put_body(channel, body, hidden_dot, part)
#	channel: socket/file descriptor to write out
#	hidden_dot: hidden dot algorithm is used if true
#	part: part number to be sent in partial message mode
#	return value:
#		 0: success
#		-1: failure
#
sub put_body (*$$$) {
    local *CHAN = shift;
    my ($Body, $hidden_dot, $part) = @_;
    my ($start, $end, $i, $line);
    my $crlf= &crlf;

    if ($part == 0) {
	$start = 0;
	$end = $#$Body;
    } else {
	$start = $main::Lines_to_partial * ($part - 1);
	$end = $main::Lines_to_partial * $part - 1;
	$end = $#$Body if ($end > $#$Body);
    }
    im_debug("entering put_body\n") if (&debug('put'));
    for ($i = $start; $i <= $end; $i++) {
	$line = $$Body[$i];
	$line .= "\n" if ($line !~ /\n$/);
	$line =~ s/\r?\n/\r\n/g if ($crlf eq "\r\n");
	$line =~ s/^\./../ if ($hidden_dot);
	im_debug("|$line") if (&debug('put'));
	return -1 unless (print CHAN $line);
#	im_debug($line);
    }
    im_debug("put_body finished: no error\n") if (&debug('put'));
    return 0;
}

##### GENERATE MIMED-BCC #####
#
# put_mimed_bcc(channel, header, body, protocol, hidden_dot, part, total)
#	channel: socket/file descriptor to write out
#	header: message header
#	bory: message body
#	hidden_dot: hidden dot algorithm is used if true
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value: (XXX)
#		 0: success
#		-1: failure
#
sub put_mimed_bcc (*$$$$$$) {
    local *CHAN = shift;
    my ($Header, $Body, $proto, $hidden_dot, $part, $total) = @_;
    my $subj;
    my $crlf = &crlf;

    return -1 unless (print CHAN "From: $main::Sender_line$crlf");
    print CHAN "To: blind-copy-recipients:;$crlf";
    print CHAN "X-Dispatcher: $main::VERSION$crlf";
    if (($subj = &header_value($Header, 'Subject')) ne '') {
	print CHAN "Subject: Bcc: $subj$crlf";
    } else {
	print CHAN "Subject: Blind Carbon Copy$crlf";
    }
    if ($main::Generate_message_id) {
	$main::Cur_mid = &gen_message_id(0);
	print CHAN "Message-Id: $main::Cur_mid$crlf";
	$First_part_mid = $main::Cur_mid if ($part == 1);
    }
    print CHAN 'Date: ' . &gen_date(1) . $crlf
	if ($main::Generate_date);
    if ($part) {
	$bcc_mid = &gen_message_id(0) unless ($bcc_mid); # XXX
	print CHAN "Mime-Version: 1.0$crlf";
	print CHAN "Content-Type: Message/partial;$crlf";
	printf CHAN "\tid=\"%s\"; number=%d; total=%d$crlf",
	    $bcc_mid, $part, $total;
	print CHAN "Content-Description: part $part of $total$crlf";
	print CHAN "References: $First_part_mid$crlf"
	    if ($part > 1);
	print CHAN $crlf;
	print CHAN "Message-Id: $bcc_mid$crlf" if ($part == 1);
    }
    if ($part <= 1) {
	print CHAN "Mime-Version: 1.0$crlf";
	print CHAN "Content-Type: Message/rfc822$crlf";
	print CHAN $crlf;

	return -1 if (&put_header(\*CHAN, $Header, $proto, 'all') < 0);
    }
    return -1 if (&put_body(\*CHAN, $Body, $hidden_dot, $part) < 0);
    return 0;
}

##### GENERATE PARTIAL/MIME #####
#
# put_mimed_partial(channel, header, body, protocol, hidden_dot, part, total)
#	channel: socket/file descriptor to write out
#	header: message header
#	bory: message body
#	hidden_dot: hidden dot algorithm is used if true
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value: (XXX)
#		 0: success
#		-1: failure
#
sub put_mimed_partial (*$$$$$$) {
    local *CHAN = shift;
    my ($Header, $Body, $proto, $hidden_dot, $part, $total) = @_;
    my $crlf = &crlf;

    return -1 if (&put_header(\*CHAN, $Header, $proto, 'partial:ext') < 0);
    if ($main::Generate_message_id) {
	$main::Cur_mid = &gen_message_id($part);
	print CHAN "Message-Id: $main::Cur_mid$crlf";
	$First_part_mid = $main::Cur_mid if ($part == 1);
    }
    print CHAN "Mime-Version: 1.0$crlf";
    print CHAN "Content-Type: Message/partial;$crlf";
    printf CHAN "\tid=\"%s\"; number=%d; total=%d$crlf",
	&header_value($Header, 'Message-Id'), $part, $total;
    print CHAN "Content-Description: part $part of $total$crlf";
    print CHAN "References: $First_part_mid$crlf" if ($part > 1);
    print CHAN "$crlf";

    if ($part == 1) {
	return -1 if (&put_header(\*CHAN, $Header, $proto, 'partial:int') < 0);
    }
    return -1 if (&put_body(\*CHAN, $Body, $hidden_dot, $part) < 0);
    return 0;
}

##### GENERATE MIMED ERROR NOTIFY #####
#
# put_mimed_error_notify(channel, header, body, recipients, status, protocol,
#			server, hidden_dot, session_log)
#	channel: socket/file descriptor to write out
#	header: message header
#	bory: message body
#	recipients:
#	status:
#	protocol:
#	server:
#	hidden_dot: hidden dot algorithm is used if true
#	session_log: logged messaged when error occurs
#	return value: (XXX)
#		 0: success
#		-1: failure
#
sub put_mimed_error_notify (*$$$$$$$$;$) {
    local *CHAN = shift;
    my ($Header, $Body, $Recp, $Stat, $proto, $server,
	$hidden_dot, $session_log, $part) = @_;    # XXX: $part missing?
    my $subj;
    my $crlf = &crlf;
    my $boundary;

    return -1 unless (print CHAN "To: $main::Sender_line$crlf");
    print CHAN "From: Imput-Error-Report$crlf";
    print CHAN "X-Dispatcher: $main::VERSION$crlf";
    if (($subj = &header_value($Header, 'Subject')) ne '') {
	print CHAN "Subject: Returned message: $subj$crlf";
    } else {
	print CHAN "Subject: Returned message$crlf";
    }
    if ($main::Generate_message_id) {
	$main::Cur_mid = &gen_message_id(0);
	print CHAN "Message-Id: $main::Cur_mid$crlf";
    }
    print CHAN 'Date: ' . &gen_date(1) . $crlf
	if ($main::Generate_date);
    print CHAN "Mime-Version: 1.0$crlf";
    print CHAN "Content-Type: Multipart/report;$crlf";
    print CHAN "\treport-type=delivery-status;$crlf";
    $boundary = &gen_message_id(0);
    $boundary =~ y/<@>/-_-/;
    print CHAN "\tboundary=\"$boundary\"$crlf";
    print CHAN "Precedence: junk$crlf";
    print CHAN $crlf;

    print CHAN "This is a MIME-encapsulated message$crlf$crlf";
    print CHAN "--$boundary$crlf";
    print CHAN $crlf;
    print CHAN "Your message was not delivered successfully.$crlf";
    my $errlog = im_saved_errors();
    if ($errlog) {
	print CHAN $crlf;
	print CHAN "Reason:$crlf";
	print CHAN "$errlog$crlf";
    }
    if ($main::Info) {
	print CHAN $crlf;
	print CHAN "$main::Info$crlf";
    }
#   my $session_log = &get_session_log();
    if ($session_log) {
	print CHAN $crlf;
	print CHAN "$session_log$crlf";
    }
    if ($#$Recp >= 0) {
	require Sys::Hostname && import Sys::Hostname;

	# host information
	my $myhostname = hostname();
	unless ($myhostname =~ /\./) {
	    my ($h) = gethostbyname($myhostname);
	    $myhostname = $h if ($h);
	}

	print CHAN "--$boundary$crlf";
	print CHAN "Content-Type: message/delivery-status$crlf";
	print CHAN $crlf;
	print CHAN "Reporting-MTA: dns; $myhostname$crlf";
#	print CHAN "Arrival-Date: (startup time)$crlf";

	my $i;
	for ($i = 0; $i <= $#$Recp; $i++) {
	    print CHAN $crlf;
	    print CHAN "Final-Recipient: rfc822; $$Recp[$i]$crlf";
	    if ($$Stat[$i] =~ /^2/) {
#		print CHAN "Action: relayed$crlf";
		print CHAN "Action: failure$crlf";
		print CHAN "Status: 5.1.5$crlf";	# XXX
	    } else {
		print CHAN "Action: failure$crlf";
		print CHAN "Status: 5.1.1$crlf";	# XXX
	    }
	    print CHAN "Remote-MTA: $server$crlf";
	    print CHAN "Diagnostic-Code: smtp; $$Stat[$i]$crlf";
	}
    }
    if ($#$Header >= 0 || $#$Body >= 0) {
	print CHAN "--$boundary$crlf";
	print CHAN "Content-Type: Message/rfc822$crlf";
	print CHAN $crlf;
	return -1 if (&put_header(\*CHAN, $Header, $proto, 'original') < 0);
	return -1 if (&put_body(\*CHAN, $Body, $hidden_dot, $part) < 0);
	print CHAN $crlf;	# a linebreak is needed here
    }
    print CHAN "--$boundary--$crlf";
    return 0;
}

##### GET SIZE OF MESSAGE #####
#
# message_size(header, body, part)
#	header: reference to a message header array
#	body: reference to a message body array
#	return value: size of whole message
#
sub message_size ($$$) {
    my ($Header, $Body, $part) = @_;
    my ($start, $end, $i, $size);

    if ($part == 0) {
	$start = 0;
	$end = $#$Body;
    } else {
	$start = $main::Lines_to_partial * ($part - 1);	# XXX?? main?
	$end = $main::Lines_to_partial * $part - 1; # XXX?? main?
	$end = $#$Body if ($end > $#$Body);
    }
    $size = 0;
    for ($i = 0; $i <= $#$Header; $i++) {
	$size += length($$Header[$i]) unless ($$Header[$i] =~ /^ KILLED /);
    }
    for ($i = $start; $i <= $end; $i++) {
	$size += length($$Body[$i]);
    }
    return $size;
}

sub set_crlf ($) {
    $crlf_char = shift;
}

sub crlf () {
    $crlf_char;
}

1;