update 20011108

#!/usr/bin/perl -w
use strict;
 
######################################################################
+####
#                                                                     
+   #
# sendmail, a perl-replacement for the original, it just collects the 
+   #
# data, and sends them to the specified eMailserver.                  
+   #
# diposition to enable mailing for servers, who don't have a dinosaur 
+:) #
#                                                                     
+   #
# No smtp after pop possible with this script!                        
+   #
# No commands the original knows are recognized!                      
+   #
#                                                                     
+   #
# put it to /usr/lib/sendmail, the standard place for the original or 
+   #
# the place it is expected.                                           
+   #
#                                                                     
+   #
# This version was designed to meet the proposals of RFC733 concerning
+   #
# the order of header information.                                    
+   #
#                                                                     
+   #
# Version: 1.01                                                       
+   #
# dor    : 20011110                                                   
+   #
# Author : Sascha Wuestemann                                          
+   #
# email  : sascha.wuestemann@epost.de                                 
+   #
#                                                                     
+   #
######################################################################
+####
 
# Requirement:
 
# module which does the mailing
# has to be installed
 
use Net::SMTP;
 
# fetch incoming data from stdin or being piped to us
 
my @textdata = <STDIN>;
 
############################
#                          #
# user setting start here: #
 
# the mailserver, which delivers mail
 
my $mailhost = "";
 
# the user, who is allowed to use the mailserver
# and gets errormessages, too
 
my $maileruser = "\@";
 
# file, where to pipe all mailcontent at.
# use only for debugging!
# if used by cgi, webserver's user needs
# rights to write there.
 
my $hclf;
#$hclf = "/tmp/sendmail.log";
 
my $mdebug;
 
# don't debug the module on stdout
 
$mdebug = 0;
 
# debug the module on stdout, default "1"
# higher values are possible but not useful
 
#$mdebug = 1;
 
# user settings stop here! #
#                          #
############################
 
if ($hclf) {
    open (GUN,">>$hclf") || die "cant write to $hclf";
    print GUN scalar localtime() . "\n@textdata\n#####################
+##############\n";
    close (GUN) || warn "cant close $hclf";
}
 
# make a copy of income data to work with
my @workrow = @textdata;
 
# order as suggested at RFC733:
my $mail_date;
my $mail_from;
my $mail_reply_to;
my $mail_subject;
# sender done by module
# no reply_to for sender possible because of module
my $mail_to;
my $mail_cc;
my $mail_bcc;
# several more headers may follow,
# but are unimportant for the module and done by it, too
 
my $i=0;
my @j;
foreach(@textdata[0..6]){
 # case insensitive is required here,
 # some clients even don't care about order of the keywords...
 # matched value may be null if headerkeyword was given but no value
 if ($_ =~ /^date\s*:\s*(.*)/i) {
     $mail_date    = $1;
     push @j,$i;
    }
 if ($_ =~ /^from\s*:\s*(.*)/i) {
     $mail_from    = $1;
     push @j,$i;
    }
 if ($_ =~ /^reply-to\s*:\s*(.*)/i) {
     $mail_reply_to= $1;
      push @j,$i;
    }
 if ($_ =~ /^subject\s*:\s*(.*)/i) {
     $mail_subject = $1;
     push @j,$i;
    }
 if ($_ =~ /^to\s*:\s*(.*)/i) {
     $mail_to      = $1;
     push @j,$i;
    }
 if ($_ =~ /^cc\s*:\s*(.*)/i) {
     $mail_cc      = $1;
     push @j,$i;
    }
 if ($_ =~ /^bcc\s*:\s*(.*)/i) {
     $mail_bcc      = $1;
     push @j,$i;
    }
 $i++;
}
 
# sort found headers reverse to get a working slice order
my @sorted_j = sort {$b <=> $a} @j;
 
foreach $i (@sorted_j) {
     if ($i ne 0) {
      splice(@workrow, $i, 1);
     }
     else {
        shift @workrow;
     }
}
 
my $mail_text;
 
# case, if mail is undeliverable
# if so, alarm defined $maileruser
 
if (! $mail_to) {
 my $whereat      = `/bin/uname -n`;
 chomp $whereat;
 $mail_to      = $maileruser;
 $mail_from    = "perlsendmail <$maileruser>";
 $mail_subject = "perlsendmail has found an error at $whereat!";
 $mail_text    = @textdata;
}
 
# if ok, init remaining vars
 
else {
 # catch empty sender,subject and date
 if (
     (! $mail_from) and
     ($ENV{USER})
    ) {
     $mail_from = $ENV{USER};
 }
 else {
     $mail_from = $maileruser;
 }
 # some clients don't give a real mailaddress
 # if so extend it to one if hostname matches, else use dummy value,
 # replace dummy value "domain.arg" to a real value, if nescessary
 if (!($mail_from=~/\@/)){
       $ENV{HOSTNAME} =~ /\.(.+)/;
       if ($1) {
        $mail_from="$mail_from\@$1"
       }
       else {
        $mail_from="$mail_from\@domain.arg"
       }
 }
 if (! $mail_subject) {
     $mail_subject = "\n" ;
 }
 if (! $mail_date) {
     $mail_date = scalar localtime();
 }
 
 unshift @workrow,"Cc: $mail_cc\n" if $mail_cc;
 unshift @workrow,"To: $mail_to\n";
 unshift @workrow,"Subject: $mail_subject\n";
 unshift @workrow,"Reply-to: $mail_reply_to\n" if $mail_reply_to;
 unshift @workrow,"From: $mail_from\n";
 unshift @workrow,"Date: $mail_date\n";
 
 # remaining elements might be other keywords followed by bodytext
 foreach (@workrow) {
    $mail_text .= $_;
 }
}
 
chomp $mail_from;
chomp $mail_to;
chomp $mail_subject;
chomp $mail_cc if $mail_cc;
chomp $mail_bcc if $mail_bcc;
 
my $smtp = Net::SMTP->new("$mailhost",
                           Debug   => $mdebug,
                      );
$smtp->mail("$mail_from");
$smtp->to("$mail_to");
$smtp->cc("$mail_cc") if $mail_cc;
$smtp->bcc("$mail_bcc") if $mail_bcc;
$smtp->data();
$smtp->datasend("$mail_text");
$smtp->dataend();
$smtp->quit;
[download]