6 $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
12 use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname($0);
18 use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG);
19 require MIME::Head; # inherits Mail::Header
20 require Mail::Address;
23 sub sendmail_show { return "\"$sendmail_orig\" ".join(",",map("\"$_\"",@ARGV)); }
25 sub sendmail_orig_exec
27 exec {$sendmail_orig} $0,@ARGV or die "exec(".sendmail_show()."): $!";
31 Getopt::Long::Configure(
35 # FIXME: workaround: 'unknown options' are considered the same as 'arguments'
36 # None of ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) can help us.
37 # No preprocessing possible as it is hard to find option arguments.
47 our $opt_F; # from PerlMail::Config;
48 my $opt_perlmail_dry_run;
49 my @ARGV_save=@ARGV; # for non-bm mode
50 die if !Getopt::Long::GetOptions(
57 "perlmail-dry-run+",\$opt_perlmail_dry_run,
60 # RedHat sendmail-8.12.5-7/sendmail/main.c/\QDo a quick prescan of the argument list.\E
61 || grep({ File::Basename::basename($0) eq $_; } "newaliases","mailq","smtpd","hoststat","purgestat")
62 # -bm: Deliver mail in the usual way (default).
63 || (defined($opt_b) && $opt_b ne "m")
64 || defined $opt_q # MD_QUEUERUN
65 || defined $opt_Q # MD_QUEUERUN
72 # RedHat sendmail-8.9.3-20/src/main.c/main()/\Qif (FullName != NULL)\E
73 # for $opt_F is implemented by Mail::Address in our &FromAddress
75 my $head=MIME::Head->new(\*STDIN);
76 # options leave in @ARGV, addresses to @addr:
77 my @args=@ARGV; # temporary
79 my @addr=(); # addresses
80 push @{(/^-./ ? \@ARGV : \@addr)},$_ for (@args);
82 for my $addrobj (map({ Mail::Address->parse($_); } map({ ($head->get($_)); } @h_rcpt))) {
83 if (!$addrobj->address()) {
84 # bogus, shouldn't happen
85 warn "->address() not found in \"".$addrobj->format()."\"";
99 my $muttrc_From=parseone(scalar muttrc_get("from")); # may get undef()!; parseone() may be redundant
100 $muttrc_From=$muttrc_From->address() if $muttrc_From;
101 $opt_f=undef() if defined($opt_f) && $muttrc_From && lc($opt_f) eq lc($muttrc_From);
103 $from_headername=$_; # leave last item in $from_headername
104 next if !(my @from_val=$head->get($from_headername));
105 @from_val=map({ ($_->address()); } map({ (Mail::Address->parse($_)); } @from_val));
106 $from_headername=undef() if !(1==@from_val && $muttrc_From && lc($from_val[0]) eq lc($muttrc_From));
108 } # fallthru with $from_headername remaining set if last headername did not exist
109 # now $from_headername contains the header name to be replaced w/substituted value
112 # to be utilized later by &FromAddress
113 our $is_pgp; # from PerlMail::Config;
115 && do { local $_=$head->mime_attr("Content-Type"); $_ && ~m#^multipart/(?:signed|encrypted)$#; }
116 && do { local $_=$head->mime_attr("Content-Type.protocol"); $_ && ~m#^application/pgp\b#; }
120 # !defined($rcpt) if we have no recipients
121 # make the list unique to prevent dupes being normally filtered by sendmail(8)
122 # one '{' is block-wrapper, another '{' is hash-indirection!
123 # hash keys are just strings, never refs!
124 # unify the list as Mail::Address instances
125 my @rcpts=(!@addr ? (undef()) : values(%{{ map({
127 $obj=parseone $obj if !ref $obj;
128 (!defined $obj ? () : (lc($obj->address())=>$obj));
131 my $stdin_body=(@rcpts<=1 ? undef() : do { # store input data only if it will be used multiple times
135 for my $rcpt (@rcpts) {
139 if (defined $rcpt) { # !defined($rcpt) if we have no recipients
141 $opt_f=FromAddress($rcpt,1)->address() if !defined $opt_f;
142 $head->replace($from_headername,FromAddress($rcpt,0)->format()) if $from_headername;
145 1; # drop '-bm' if present as it is default anyway
146 1; # drop '-t' if present as we are looping now for it
147 push @ARGV,"-f",$opt_f if defined $opt_f;
148 # we don't handle "Full-Name" header thus pass "-F"
149 # "From/Resent-From" should be handled by our &FromAddress
150 push @ARGV,"-F",$opt_F if defined $opt_F;
151 push @ARGV,$rcpt->address() if defined $rcpt;
152 push @ARGV,@addr_addon;
154 local $SIG{"PIPE"}=sub { die "Got SIGPIPE from ".sendmail_show(); };
156 if ($opt_perlmail_dry_run) {
157 print sendmail_show()."\n";
161 defined (my $pid=open SENDMAIL,"|-") or die "Cannot fork to spawn ".sendmail_show().": $!";
162 sendmail_orig_exec() if !$pid; # child
164 $head->print(\*SENDMAIL);
165 print SENDMAIL "\n"; # MIME::Head->print() eats the empty line but it doesn't print it
166 if (defined($stdin_body)) {
167 print SENDMAIL $stdin_body;
176 next if $opt_perlmail_dry_run; # don't close our STDOUT as it is aliased to *SENDMAIL
177 close SENDMAIL or warn "close(".sendmail_show()."): $?=".join(",",
178 (!WIFEXITED($?) ? () : ("EXITSTATUS(".WEXITSTATUS($?).")")),
179 (!WIFSIGNALED($?) ? () : ("TERMSIG(" .WTERMSIG($?) .")")),
180 (!WIFSTOPPED($?) ? () : ("STOPSIG(" .WSTOPSIG($?) .")")),
182 my $gotcode=(!WIFEXITED($?) ? 99 : WEXITSTATUS($?));
183 $exitcode=$gotcode if $gotcode>$exitcode;