X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-sendmail;h=6a4e31e2d1fd4d5cbeb2d2a5a7742b7c0a6f9c05;hp=900ddede1cb714560ec5df440fba95d25a90d8ce;hb=cf13558ac1b01fd521a7bb727cd8ab3acecb1211;hpb=cc75dffdfe36f7a253c4cfe0555c09fca28d360a diff --git a/perlmail-sendmail b/perlmail-sendmail index 900dded..6a4e31e 100755 --- a/perlmail-sendmail +++ b/perlmail-sendmail @@ -7,143 +7,17 @@ $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; use strict; use warnings; +use File::Basename; +BEGIN { + use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname($0); + use PerlMail::Config; + use PerlMail::Lib; + } + require Getopt::Long; use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG); require MIME::Head; # inherits Mail::Header require Mail::Address; -require File::Basename; -require Mail::Alias; - -my $sendmail_orig=(-x ($_="/usr/sbin/sendmail-orig") ? $_ : "/usr/sbin/sendmail"); -my $HOME="/home/short"; -# Mail-Alias-1.12 defaults to "/etc/mail/aliases" which does not exist on RedHat sendmail-8.12.5-7 -# Mail-Alias-1.12 will clutter $_ ! -my @addr_addon=(Mail::Alias->new("/etc/aliases")->exists("sentout") ? ("sentout") : ()); -my $opt_F; -my $is_pgp; -sub FromAddress -{ -my($rcpt,$iserror)=@_; - - my $phrase=(defined $opt_F ? $opt_F : "Jan Kratochvil"); - { - last if !$is_pgp; - last if $iserror; - local *F; - local $_; - my $filename="$HOME/.gnupg/options"; - open F,$filename or do { warn "Open \"$filename\": $!"; last; }; - local $/="\n"; - my @keys=map((/^\s*default-key\s+(\S+)\s*$/),); - @keys==1 or do { warn "Found ".scalar(@keys)." 'default-key's in your \"$filename\", ignoring"; last; }; - close F or warn "Close \"$filename\": $!"; - my $default_key=$keys[0]; - $default_key=~/^[[:xdigit:]]{8}$/ or do { warn "Invalid 'default-key', ignoring: $default_key"; last; }; - return Mail::Address->new( - $phrase, - 'pgp-'.uc($default_key).'@jankratochvil.net', - ); - } - # !$is_pgp or fallback - return Mail::Address->new( - $phrase, - (!$iserror ? 'rcpt' : 'rcpterr') - .'-' - .(defined($rcpt->user()) ? $rcpt->user() : "NOUSER") - .".AT." - .(defined($rcpt->host()) ? $rcpt->host() : "LOCAL") - .'@jankratochvil.net', - ); -} - -# RedHat sendmail-8.9.3-20/src/conf.c/HdrInfo[]/\Q/* destination fields */\E -# FIXME: Recognize "Resent-$_" headers for -t but when we are in 'resent' mode? -my @h_rcpt=( # case in-sensitive! - "To", - "Cc", - "Bcc", - "Apparently-To", - ); - -# ordering matters; first header found is substituted -# last header is subsituted if no one is found -my @h_from=( - "Resent-From", - "From", - ); - - -# FIXME: modularized unification with 'lacemail-accept' -# BEGIN lacemail-accept -our %muttrc_pending=(); -sub muttrc -{ -my($muttrc)=@_; - - $muttrc||="$HOME/.muttrc"; - $muttrc=~s/^\~/$HOME/; - do { warn "Looping muttrc, ignoring: $muttrc"; return (); } if $muttrc_pending{$muttrc}; - local $muttrc_pending{$muttrc}=1; - local *MUTTRC; - open MUTTRC,$muttrc or do { warn "open \"$muttrc\": $!"; return (); }; - local $/="\n"; - local $_; - my @r=(); - # far emulation mutt/init.c/mutt_parse_rc_line() - while () { - s/^[\s;]*//s; - s/[#;].*$//s; - s/\s*$//s; - next if !/^(\S+)\s*/s; - if ($1 eq "source") { - $_=$'; - do { warn "Wrong 'source' parameters at $muttrc:$.: $_"; next; } if !/^\S+$/; - push @r,muttrc($_); - next; - } - push @r,$_; - } - close MUTTRC or warn "close \"$muttrc\": $!"; - return wantarray() ? @r : join("",map("$_\n",@r)); -} - -my %mutteval_charmap=( # WARNING: Don't use "" or "0" here, see below for "|| warn"! - '\\'=>"\\", - 'r'=>"\r", - 'n'=>"\n", - 't'=>"\t", - 'f'=>"\f", - 'e'=>"\e", - ); -# mutt/init.c/mutt_extract_token() -sub mutteval -{ - local $_=$_[0]; - return $_ if !s/^"//; - do { warn "Missing trailing quote in: $_"; return $_; } if !s/"$//; - s/\\(.)/$mutteval_charmap{$1} || warn "Undefined '\\$1' sequence in: $_";/ges; - return $_; -} - -sub muttrc_get -{ -my(@headers)=@_; - - my @r=map({ (ref $_ ? $_ : qr/^\s*set\s+\Q$_\E\s*=\s*(.*?)\s*$/si); } @headers); - my %r=map(($_=>undef()),@r); - for (muttrc()) { - for my $ritem (@r) { - /$ritem/si or next; - $r{$ritem}=mutteval $1; - } - } - for my $var (grep { !defined($r{$_}) } @r) { - warn "Variable '$var' not found in muttrc"; - return undef(); - } - return wantarray() ? %r : $r{$r[0]}; -} -# END lacemail-accept sub sendmail_show { return "\"$sendmail_orig\" ".join(",",map("\"$_\"",@ARGV)); } @@ -170,8 +44,8 @@ my $opt_Q; my $opt_q; my $opt_t; our $opt_f; -#my $opt_F; # declared before &FromAddress already -my $opt_lacemail_dry_run; +our $opt_F; # from PerlMail::Config; +my $opt_perlmail_dry_run; my @ARGV_save=@ARGV; # for non-bm mode die if !Getopt::Long::GetOptions( "b=s" ,\$opt_b, @@ -180,7 +54,7 @@ die if !Getopt::Long::GetOptions( "t" ,\$opt_t, "f=s" ,\$opt_f, "F=s" ,\$opt_F, - "lacemail-dry-run+",\$opt_lacemail_dry_run, + "perlmail-dry-run+",\$opt_perlmail_dry_run, ); if (0 # RedHat sendmail-8.12.5-7/sendmail/main.c/\QDo a quick prescan of the argument list.\E @@ -199,11 +73,6 @@ if (0 # for $opt_F is implemented by Mail::Address in our &FromAddress my $head=MIME::Head->new(\*STDIN); -# We may (=will) change the contents and send it multiple times -if (defined(my $msgid=$head->get("Message-ID"))) { - $head->delete("Message-ID"); - $head->replace("X-LaceMail-sendmail-Message-ID",$msgid); - } # options leave in @ARGV, addresses to @addr: my @args=@ARGV; # temporary @ARGV=(); # options @@ -220,17 +89,6 @@ if ($opt_t) { } } -# return: Mail::Address instance or undef() -sub parseone -{ -my($line)=@_; - - return undef() if !defined $line; - my @r=Mail::Address->parse($line); - warn "Got ".scalar(@r)." addresses while wanting just one; when parsing: $line" if 1!=@r; - return $r[0]; -} - sub matches { return @@ -252,6 +110,7 @@ my $from_headername; } # to be utilized later by &FromAddress +our $is_pgp; # from PerlMail::Config; $is_pgp=(1 && do { local $_=$head->mime_attr("Content-Type"); $_ && ~m#^multipart/(?:signed|encrypted)$#; } && do { local $_=$head->mime_attr("Content-Type.protocol"); $_ && ~m#^application/pgp\b#; } @@ -294,7 +153,7 @@ for my $rcpt (@rcpts) { local $SIG{"PIPE"}=sub { die "Got SIGPIPE from ".sendmail_show(); }; local *SENDMAIL; - if ($opt_lacemail_dry_run) { + if ($opt_perlmail_dry_run) { print sendmail_show()."\n"; *SENDMAIL=\*STDOUT; } @@ -314,7 +173,7 @@ for my $rcpt (@rcpts) { } } - next if $opt_lacemail_dry_run; # don't close our STDOUT as it is aliased to *SENDMAIL + next if $opt_perlmail_dry_run; # don't close our STDOUT as it is aliased to *SENDMAIL close SENDMAIL or warn "close(".sendmail_show()."): $?=".join(",", (!WIFEXITED($?) ? () : ("EXITSTATUS(".WEXITSTATUS($?).")")), (!WIFSIGNALED($?) ? () : ("TERMSIG(" .WTERMSIG($?) .")")),