X-Git-Url: https://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-sendmail;h=2177e2ce62738bd3eea7bf2ab6ac811be8750d72;hp=4831db221e6eb4535712409d287cc179c8f62bc8;hb=0c848de6fd9c35f1ec9640b3adbab036ce0a5a91;hpb=642743bdc07dbcea55e4f580b894fd87cc3992b8 diff --git a/perlmail-sendmail b/perlmail-sendmail index 4831db2..2177e2c 100755 --- a/perlmail-sendmail +++ b/perlmail-sendmail @@ -1,128 +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; -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; -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)); } @@ -148,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, @@ -159,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 @@ -177,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 @@ -199,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 @@ -230,8 +125,24 @@ my $from_headername; # 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(); ; @@ -242,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 @@ -261,7 +172,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; } @@ -270,7 +181,7 @@ for my $rcpt (@rcpts) { sendmail_orig_exec() if !$pid; # child } $head->print(\*SENDMAIL); - print SENDMAIL "\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; } @@ -281,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($?) .")")),