#! @PERL@ -w
use Getopt::Long;
use strict;
# This ugly trick lets the script work even if gettext support is missing.
# We did so because Locale::gettext doesn't ship with the standard perl
# distribution.
BEGIN {
if (eval { require Locale::gettext }) {
import Locale::gettext;
require POSIX;
import POSIX, qw(setlocale);
} else {
eval '
use constant LC_MESSAGES => 0;
sub setlocale($$) { }
sub bindtextdomain($$) { }
sub textdomain($) { }
sub gettext($) { shift }
'
}
}
setlocale(LC_MESSAGES, "");
bindtextdomain("quilt", "@LOCALEDIR@");
textdomain("quilt");
sub _($) {
return gettext(shift);
}
my (%append_name, %append_value, $remove_empty_headers, %remove_header,
%extract_recipients, %replace_name, %replace_value, $charset);
GetOptions('add-recipient:s%' =>
sub {
$append_name{lc $_[1]} = $_[1];
$append_value{lc $_[1]} .= ",\n " . $_[2];
},
'remove-header:s' => sub { $remove_header{lc $_[1]}++ },
'remove-empty-headers' => \$remove_empty_headers,
'replace-header:s%' =>
sub {
$replace_name{lc $_[1]} = $_[1];
$replace_value{lc $_[1]} = $_[2];
},
'extract-recipients:s' => sub { $extract_recipients{lc $_[1]} = 1 },
'charset' => \$charset)
or exit 1;
my %recipient_headers = map {lc $_ => 1} (@ARGV, keys %append_name);
# Email address formats understood:
# Andreas Gruenbacher <agruen@suse.de>
# "Andreas G." <agruen@suse.de>
# agruen@suse.de (Andreas Gruenbacher)
# agruen@suse.de
# agruen@[suse.de]
#
# Not understood (needs proper encoding):
# Andreas Grünbacher <agruen@suse.de>
sub check_recipient($) {
my ($recipient) = @_;
my ($display, $deliver);
local $_ = $recipient;
my $spl = '()<>\[\]:;@\\,"'; # special characters
my $spldot = "$spl."; # special characters + dot
# FIXME: Take a character set option and if set, encode invalid
# characters in atoms: =?iso-8859-1?q?Gr=FCnbacher?=
if (($display, $deliver) = /^(.*?)\s*<(.+)>$/ or
($deliver, $display) = /^(\S*)(\s*\(.*\))$/) {
$_ = $display;
if (/^"((?:[^"\\]|\\[^\n\r])*)"/) {
$display = $1;
} else {
# The value is not (properly) quoted. Check for invalid characters.
while (/\(/ or /\)/) {
die sprintf(
_("Display name '%s' contains unpaired parentheses\n"), $display)
unless s/\(([^()]*)\)/$1/;
}
die sprintf(
_("Display name '%s' contains invalid characters\n"), $display)
if /[$spldot]/;
}
die sprintf(
_("Display name '%s' contains non-printable or 8-bit characters\n"), $display)
if (/[^ \t\40-\176]/);
} else {
$deliver = $_;
}
# Check for a valid delivery address
die sprintf(_("Delivery address '%s' is invalid\n"), $deliver)
if $deliver =~ /[ \t]/ or $deliver =~ /[^ \t\40-\176]/ or
$deliver !~ /^[^$spl]+@(\[?)[^$spldot]+(?:\.[^$spldot]+)*(\]?)$/ or
(!$1) != (!$2);
return $deliver;
}
my %recipients;
sub process_header($) {
local ($_) = @_;
my ($name, $value);
return unless defined $_;
unless (($name, $value) = /^([\41-\176]+):\s*(.*)\s*/s) {
print;
return
}
if (%extract_recipients) {
if (exists $extract_recipients{lc $name}) {
#print "(($value))";
$value =~ s/^\s*//; $value =~ s/\s*$//;
foreach my $recipient (split /\s*,\s*/s, $value) {
next if $recipient =~ /^\s*$/;
#print "<<$recipient>>";
print check_recipient($recipient), "\n";
}
}
return;
}
return if exists $remove_header{lc $name};
if (exists $replace_name{lc $name}) {
if (exists $replace_value{lc $name}) {
print "$replace_name{lc $name}: $replace_value{lc $name}\n";
delete $replace_value{lc $name};
}
return;
}
if (exists $recipient_headers{lc $1}) {
if (exists $append_name{lc $name}) {
$value .= $append_value{lc $name};
delete $append_name{lc $name};
}
my @recipients;
# This is a recipients field. Split out all the recipients and
# check the addresses. Suppress duplicate recipients.
$value =~ s/^\s*//; $value =~ s/\s*$//;
foreach my $recipient (split /\s*,\s*/, $value) {
next if $recipient =~ /^\s*$/;
my $deliver = check_recipient($recipient);
push @recipients, $recipient
unless exists $recipients{$deliver};
$recipients{$deliver} = $deliver;
}
print "$name: ", join(",\n ", @recipients), "\n"
if @recipients || !$remove_empty_headers;
} else {
print if $value ne "" || !$remove_empty_headers;
}
}
my $header;
while (<STDIN>) {
last if (/^$/);
if (/^\S/) {
process_header $header;
undef $header;
}
$header .= $_;
}
process_header $header;
foreach my $name (keys %append_name) {
process_header $append_name{$name} . ': ' . $append_value{$name};
}
unless (%extract_recipients) {
# Copy the message body to standard output
# FIXME check for 7-bit clean, else assume $charset
# FIXME if UTF-8, check for invalid characters!
# FIXME must make sure that all messages are written in
# either 7-bit or $charset => mbox !!!
# Content-Transfer-Encoding: 7bit
# Content-Transfer-Encoding: 8bit
# Content-Type: text/plain; charset=ISO-8859-15
# Content-Type: text/plain; charset=UTF-8
undef $/;
print "\n", <STDIN>;
}