NetNews Usenet Archive 1992 #18/NN_1992_18.iso/spool/comp/lang/perl/5410

Internet Message Format | 1992-08-21 | 5.8 KB

Path: sparky!uunet!dtix!darwin.sura.net!convex!convex!tchrist
From: [e-mail] (Tom Christiansen)
Newsgroups: comp.lang.perl
Subject: Re: Perl "mail munger"
Message-ID: <[e-mail]>
Date: 21 Aug 92 13:28:46 GMT
References: <[e-mail]>
Sender: [e-mail] (news access account)
Reply-To: [e-mail] (Tom Christiansen)
Organization: Convex Computer Corporation, Colorado Springs, CO
Lines: 220
Originator: [e-mail]
Nntp-Posting-Host: pixel.convex.com
X-Disclaimer: This message was written by a user at CONVEX Computer
              Corp. The opinions expressed are those of the user and
              not necessarily those of CONVEX.

From the keyboard of [e-mail] (Bob Snyder):
:Does anyone have a perl "mail munger" that goes thorugh the mail spool
:directory, and chops up a user's mail file if it is too large, and moves
:that piece someplace else?
:
:This seems like something perl should be good at (I'm learning perl slowly, and
:disecting a script like this would be beneficial).

Consider this....

--tom

#!/usr/bin/perl
# forwmail -- [e-mail]

# ===========   begin configuration section

$DOMAIN  = '\.convex\.com';     # remember to turn off regexp magic
$ALIASES = '/usr/lib/aliases';
$SPOOL   = '/usr/spool/mail';

# ===========   end configuration section

($program = $0) =~ s,.*/,,;

$| = 1;


&source('stat.pl');
&source('getopts.pl');

&Getopts('nv') || die "usage: $program [-nv]\n";

$verbose = $opt_v;
$doit    = !$opt_n;

chop($hostname = `hostname`);
($host = $hostname) =~ s/$DOMAIN//;  # chop domainname

print "running $program on $host";
print " ($hostname)" if $host ne $hostname;
print "\n";

chdir $SPOOL || die "absurd chdir failure to $SPOOL: $!";

unless (-f "$ALIASES.pag" && dbmopen(aliases, $ALIASES, 0644)) {
    $slow++;
    print "no dbm file: doing aliases the hard way\n";
    print STDERR "can't open dbm file $ALIASES: $!\n";
    open ALIASES || die "couldn't read $ALIASES: $!";
    while (<ALIASES>) {
    next if /^#/ || ! /^(\S+)\s*:\s+(.*)/;
    $aliases{$1} = $2;
    }
    close ALIASES;
}

foreach $mbox ( <*> ) {

    unless (&Stat($mbox)) {
    print STDERR "couldn't stat $mbox: $!\n";
    next;
    }

    if (!($alias = $aliases{$slow ? $mbox : "$mbox\000" })) {
    if ($st_size == 0) {
        print "deleting zero-length non-mbox $mbox\n";
        if ($doit) {
        unlink($mbox) || print STDERR "can't unlink $mbox: $!\n";
        }
        next;
    }
    print "forwarding bogus mbox $mbox to postmaster\n";
    if ($doit) {
        unless (rename($mbox, "$mbox.$$")) {
        print STDERR "can't rename $mbox to $mbox.$$: $!\n";
        next;
        }
        system "Mail -s 'bogus mailbox from $mbox@$host' postmaster < $mbox.$$";
        unlink("$mbox.$$") || print STDERR "can't unlink $mbox.$$: $!\n";
    }
    next;
    }

    chop($alias) unless $slow;
    $alias =~ s/^\s*(.*)\s*$/$1/g;
    $alias =~ s/$DOMAIN//g;

    if ($alias eq "$host!$mbox"  ||     # uucp style alias to me
    $alias eq "$mbox@$host"  ||     # inet style alias to me
    $alias eq $mbox          ||     # no host specified
    $alias eq "localhost!$host")     # strange alias
    {
    print "ok for $mbox to live on $host, as alias is $alias\n"
        if $verbose;
    next;
     }

    if ($st_size == 0) {
    print "deleting zero-length mbox $mbox\n";
    if ($doit) {
        unlink($mbox) || print STDERR "can't unlink $mbox: $!\n";
    }
    next;
    }


    print "forwarding misdelivered $mbox to $alias ";

    unless ($doit) {
    print "\n";
    next;
    }

    $alias = $mbox if $alias =~ /\|/;

    unless (rename($mbox, "$mbox.$$")) {
    print STDERR "can't rename $mbox to $mbox.$$: $!\n";
    next;
    }

    unless (open(mbox, "$mbox.$$")) {
    print STDERR "can't read $mbox: $!\n";
    next;
    }

    $mail = '';
    $count = 0;
    $status = 0;
    while (<mbox>) {
    if (/^From\s/) {
        if ($mail) {
        chop($mail);
        $status |= &send($mail, $alias);
        $mail = '';
        }
    } else {
        $mail .= $_;
    }
    }
    $status |= &send($mail, $alias) if $mail;

    printf "%d piece%s\n", $count, $count == 1 ? "" : "s";

    printf "\ttotal size %d, age %s\n", $st_size, &dtime(time - $st_mtime)
    if $verbose;

    if ($status) {
    print STDERR "bad status from mail: $status\n";
    next;
    }

    unlink("$mbox.$$") || print "$mbox.$$ disappeared!\n";
}


###########################################################################
sub source {
    local($file) = @_;
    local($return) = 0;

    $return = do $file;
    die "couldn't parse $file: $@" if $@;
    die "couldn't do $file: $!" unless defined $return;
    die "couldn't run $file" unless $return;
    $return;
}

###########################################################################

sub dtime {
    local($seconds) = $_[0];
    local($days,$hours,$minutes, $retval);

    $days =  int($seconds  / (24 * 3600));
    $seconds -= $days * (24 * 3600);

    $hours =  int($seconds / 3600);
    $seconds -= $hours * 3600;

    $minutes =  int($seconds / 60);
    $seconds -= $minutes * 60;

    $retval =  "$days days" if $days;

    if ($hours) {
    $retval .= ", " if $retval;
    $retval .= "$hours hours";
    }

    if ($minutes) {
    $retval .= ", " if $retval;
    $retval .= "$minutes minutes";
    }

    if ($seconds) {
    $retval .= ", " if $retval;
    $retval .= "$seconds seconds";
    }

    $retval;
}

sub send {
    local($text, $whom) = @_;
    $count++;

    printf "\tpiece %d, size %-5d\n", $count, length($text) if $verbose;

    open (PIPE, "|/usr/lib/sendmail -odq -oi -t");
    print PIPE "Resent-to: $alias\n";
    print PIPE "Resent-comment: lost mail for $mbox found on $host\n";
    print PIPE $text;
    !close PIPE;
}
--
    Tom Christiansen      [e-mail]      convex!tchrist
There are probably better ways to do that, but it would make the parser
more complex.  I do, occasionally, struggle feebly against complexity...  :-)
            --Larry Wall in <[e-mail]>