X-Git-Url: https://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-sendmail;h=2177e2ce62738bd3eea7bf2ab6ac811be8750d72;hp=3b50a0dc05a5d370a2a0ef5e334b3492abc70227;hb=0c848de6fd9c35f1ec9640b3adbab036ce0a5a91;hpb=875355b248128758ddfdd048bf8b054e1f8c08f7 diff --git a/perlmail-sendmail b/perlmail-sendmail index 3b50a0d..2177e2c 100755 --- a/perlmail-sendmail +++ b/perlmail-sendmail @@ -1,124 +1,40 @@ #! /usr/bin/perl -# -# $Id$ +# +# $Id$ +# Copyright (C) 2002-2003 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + use vars qw($VERSION); $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; use strict; use warnings; +use File::Basename; +use File::Spec::Link; +BEGIN { + eval 'use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname(File::Spec::Link->resolve($0));'; + } +use PerlMail::Config; +use PerlMail::Lib; + require Getopt::Long; use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG); -require Mail::Header; +require MIME::Head; # inherits Mail::Header require Mail::Address; -require File::Basename; - -my $sendmail_orig=(-x ($_="/usr/sbin/sendmail-orig") ? $_ : "/usr/sbin/sendmail"); -my $HOME="/home/short"; -my $opt_F; -sub FromAddress -{ -my($rcpt,$iserror)=@_; - - return Mail::Address->new( - (defined $opt_F ? $opt_F : "Jan Kratochvil"), - (!$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)); } @@ -144,9 +60,8 @@ my $opt_b; 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; # not exported, just for local() +my $opt_perlmail_dry_run; my @ARGV_save=@ARGV; # for non-bm mode die if !Getopt::Long::GetOptions( "b=s" ,\$opt_b, @@ -155,7 +70,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 @@ -173,12 +88,7 @@ if (0 # RedHat sendmail-8.9.3-20/src/main.c/main()/\Qif (FullName != NULL)\E # for $opt_F is implemented by Mail::Address in our &FromAddress -my $head=Mail::Header->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); - } +my $head=MIME::Head->new(\*STDIN); # options leave in @ARGV, addresses to @addr: my @args=@ARGV; # temporary @ARGV=(); # options @@ -195,17 +105,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 @@ -216,18 +115,34 @@ my $from_headername; my $muttrc_From=parseone(scalar muttrc_get("from")); # may get undef()!; parseone() may be redundant $muttrc_From=$muttrc_From->address() if $muttrc_From; $opt_f=undef() if defined($opt_f) && $muttrc_From && lc($opt_f) eq lc($muttrc_From); - my @from_val; for (@h_from) { $from_headername=$_; # leave last item in $from_headername - last if @from_val=$head->get($from_headername); - } - @from_val=map({ ($_->address()); } map({ (Mail::Address->parse($_)); } @from_val)); - $from_headername=undef() if !(1==@from_val && $muttrc_From && lc($from_val[0]) eq lc($muttrc_From)); + next if !(my @from_val=$head->get($from_headername)); + @from_val=map({ ($_->address()); } map({ (Mail::Address->parse($_)); } @from_val)); + $from_headername=undef() if !(1==@from_val && $muttrc_From && lc($from_val[0]) eq lc($muttrc_From)); + last; + } # fallthru with $from_headername remaining set if last headername did not exist # now $from_headername contains the header name to be replaced w/substituted value } +# to be utilized later by &FromAddress +$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#; } + ); + my $exitcode=0; -my @rcpts=(@addr ? @addr : (undef())); # !defined($rcpt) if we have no recipients +# !defined($rcpt) if we have no recipients +# make the list unique to prevent dupes being normally filtered by sendmail(8) +# one '{' is block-wrapper, another '{' is hash-indirection! +# hash keys are just strings, never refs! +# unify the list as Mail::Address instances +my @rcpts=(!@addr ? (undef()) : values(%{{ map({ + my $obj=$_; + $obj=parseone $obj if !ref $obj; + (!defined $obj ? () : (lc($obj->address())=>$obj)); + } @addr) }})); + my $stdin_body=(@rcpts<=1 ? undef() : do { # store input data only if it will be used multiple times local $/=undef(); ; @@ -238,12 +153,12 @@ for my $rcpt (@rcpts) { if (defined $rcpt) { # !defined($rcpt) if we have no recipients local $_; - if (!ref $rcpt) { - $rcpt=parseone $rcpt; - next if !defined $rcpt; - } $opt_f=FromAddress($rcpt,1)->address() if !defined $opt_f; - $head->replace($from_headername,FromAddress($rcpt,0)->format()) if $from_headername; + if ($from_headername) { + if (my $fromaddr=FromAddress($rcpt,0)->format()) { + $head->replace($from_headername,$fromaddr); + } + } } 1; # drop '-bm' if present as it is default anyway @@ -253,10 +168,11 @@ for my $rcpt (@rcpts) { # "From/Resent-From" should be handled by our &FromAddress push @ARGV,"-F",$opt_F if defined $opt_F; push @ARGV,$rcpt->address() if defined $rcpt; + push @ARGV,@addr_addon; 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; } @@ -265,7 +181,7 @@ for my $rcpt (@rcpts) { sendmail_orig_exec() if !$pid; # child } $head->print(\*SENDMAIL); - print "\n"; # Mail::Header->print() eats the empty line but it doesn't print it + print SENDMAIL "\n"; # MIME::Head->print() eats the empty line but it doesn't print it if (defined($stdin_body)) { print SENDMAIL $stdin_body; } @@ -276,7 +192,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($?) .")")),