—
—

              
#!/usr/bin/perl
HideShow 11 lines of Pod
=begin metadata
Name: mail
Description: send and receive mail
Author: Clinton Pierce, clintp@geeksalad.org
License: perl
=end metadata
=cut
use strict;
package PerlPowerTools::mailprog;
sub DESTROY { }
1;
package
        mailer; # hide from PAUSE
use base 'PerlPowerTools::mailprog';
use IO::Socket;
use Sys::Hostname qw();
sub get_user { $_[0]->{'user'} }
sub get_hostname { $_[0]->{'hostname'} }
sub get_relayhost { $_[0]->{'relayhost'} }
sub get_replyaddr { $_[0]->{'replyaddr'} }
sub get_socket { $_[0]->{'socket'} }
sub set_user { $_[0]->{'user'} = $_[1] }
sub set_hostname { $_[0]->{'hostname'} = $_[1] }
sub set_relayhost { $_[0]->{'relayhost'} = $_[1] }
sub set_replyaddr { $_[0]->{'replyaddr'} = $_[1] }
sub set_socket { $_[0]->{'socket'} = $_[1] }
sub new {
        my $class=shift;
        my $self = {};
        if (@_) {
                my $a;
                while(defined ($a=shift)) {
                        $self->{$a}=shift;
                }
        }
        bless($self, $class);
        #
        # Ok, this is where I start making assumptions
        # I'm doing this by hand because of the PPT "requirement" that
        # only core-modules be used.  Mail::Mailer would be MUCH better
        # suited for this task IMHO...
        #
        if (! exists $ENV{REPLYADDR}) {
                # Find my name...
                if (! defined $self->get_user) {
                        if (exists $ENV{USER} or exists $ENV{LOGNAME}) {
                                if (exists $ENV{USER}) {
                                        $self->set_user($ENV{USER});
                                } else {
                                        $self->set_user($ENV{LOGNAME});
                                }
                        } else {
                                die "Your username is not defined.  \$USER or \$LOGNAME must be set.\n";
                        }
                }
                # Find my address...
                if (! defined $ENV{HOSTNAME}) {
                        my $hostname = Sys::Hostname::hostname();
                        if (! $hostname) {
                                die "Unable to find a reasonable hostname.  Use \$HOSTNAME.\n";
                        }
                        $self->set_hostname($hostname);
                } else {
                        $self->set_hostname($ENV{HOSTNAME});
                }
                # Don't like this?  Too bad.  That's why ken gave us an environment...
                $self->set_replyaddr($self->get_user . "@" . $self->get_hostname);
        } else {
                $self->set_replyaddr($ENV{REPLYADDR});  # Better be valid!
        }
        my $emsg;
        if (! exists $ENV{RELAYHOST}) {
                # Expensive.  Check to see if this system answers SMTP
                $self->set_relayhost('localhost');
                $emsg="You did not specify an \$RELAYHOST\nor this system is not listening to SMTP\n";
        } else {
                $self->set_relayhost($ENV{RELAYHOST});
                $emsg="Unable to connect to the specified relay host\n";
        }
        my $socket = IO::Socket::INET->new(
                        PeerAddr => $self->get_relayhost,
                        PeerPort => 25,
                        Proto => "tcp",
                        Type => SOCK_STREAM,
                        Timeout => 15,
        );
        die $emsg . $IO::Socket::errstr . "\n" unless $socket;
        my($ofh)=select($socket); $|=1; select($ofh);
        # Get the SMTP header
        $_=<$socket>;
        $self->set_socket($socket);   # Use this quickly, it may expire.
        return $self;
}
sub send {
        my $self=shift;
        my $message=shift;   # Full message object.
        # Ok, here we go.
        my $sock = $self->get_socket;
        main::debug("Mailed from " . $self->get_replyaddr);
        print $sock "mail from: " . $self->get_replyaddr . "\n";  $_=<$sock>;
        {
           if (defined $message->get_to) {
                foreach my $recipient (@{$message->get_to}) {
                        main::debug("Sending to recipient $recipient");
                        print $sock "rcpt to: $recipient\n";
                        $_=<$sock>; main::debug("reply: $_");
                }
           } else {
                die "No recipient.\n";
           }
           if (defined $message->get_cc) {
                foreach my $recipient (@{$message->get_cc}) {
                        main::debug("Sending to recipient $recipient");
                        print $sock "rcpt to: $recipient\n";
                        $_=<$sock>; main::debug("reply: $_");
                }
           }
           if (defined $message->get_bcc) {
                foreach my $recipient (@{$message->get_bcc}) {
                        main::debug("Sending to recipient $recipient");
                        print $sock "rcpt to: $recipient\n";
                        $_=<$sock>; main::debug("reply: $_");
                }
           }
           my($to,$cc);
           $to=join(', ', @{$message->get_to});
           print $sock "data\n";    $_=<$sock>;
           if ($to) {
                print $sock "To: $to\n";
           }
           if (defined $message->get_cc) {
                $cc=join(', ', @{$message->get_cc});
                print $sock "Cc: $cc\n";
           }
           if ($message->get_subject) {
                print $sock "Subject: " . $message->get_subject . "\n";
           }
           print $sock "X-Mailer: Perl Power Tools mail v", $main::VERSION, "\n\n";
           print $sock $message->body;
           print $sock "\n.\n";
           $_=<$sock>;
           main::debug("received after body: $_");
        }
}
sub DESTROY {
        my $self=shift;
        my $sock = $self->get_socket;
        close($sock) if defined $sock;
}
1;
package
        message; # hide from PAUSE
use base 'PerlPowerTools::mailprog';
sub get_subject { $_[0]->{'subject'} }
sub get_from { $_[0]->{'from'} }
sub is_deleted { $_[0]->{'deleted'} }
sub is_read { $_[0]->{'read'} }
sub neverseen { $_[0]->{'neverseen'} }
sub get_to { $_[0]->{'to'} }
sub get_bcc { $_[0]->{'bcc'} }
sub get_cc { $_[0]->{'cc'} }
sub get_lines { $_[0]->{'lines'} }
sub get_bytes { $_[0]->{'bytes'} }
sub get_date { $_[0]->{'date'} }
sub get_sequence { $_[0]->{'sequence'} }
sub set_subject { $_[0]->{'subject'} = $_[1] }
sub set_from { $_[0]->{'from'} = $_[1] }
sub set_deleted { $_[0]->{'deleted'} = $_[1] }
sub set_read { $_[0]->{'read'} = $_[1] }
sub set_neverseen { $_[0]->{'neverseen'} = $_[1] }
sub set_to { $_[0]->{'to'} = $_[1] }
sub set_bcc { $_[0]->{'bcc'} = $_[1] }
sub set_cc { $_[0]->{'cc'} = $_[1] }
sub set_lines { $_[0]->{'lines'} = $_[1] }
sub set_bytes { $_[0]->{'bytes'} = $_[1] }
sub set_date { $_[0]->{'date'} = $_[1] }
sub set_sequence { $_[0]->{'sequence'} = $_[1] }
sub new {
        my $class=shift;
        my $self = {};
        bless($self, $class);
        return $self;
}
sub load_from_array {   # Already chomped.
        my $self=shift;
        my($l, @head, @body);
        $self->set_lines(scalar @_);
        my $bytes;
        foreach(@_) {
                $bytes+=length($_);
        }
        $bytes += ($self->get_lines) * length($/);  # Correct for chomp.
        $self->set_bytes($bytes);
        while($l=shift) {
                push(@head, $l)
        }
        @body=@_;
        push(@{$self->{body}}, @body);
        push(@{$self->{head}}, @head);
        $self->_extract;
}
sub _extract {
        my $self=shift;
        my @hc;
        foreach(@{$self->{head}}) {
                unless (/^\s+/) {
                        push(@hc, $_);
                } else {
                        $hc[$#hc].=$_;
                }
        }
        $self->set_neverseen(1);
        $self->set_read(0);
        my $line;
        while ($line=shift @hc) {
                my($foo, $bar);
                if (($foo)=$line=~/^Subject:\s+(.*)/i) {
                        $self->set_subject($foo);
                }
                # Ok, so beat me over the head with an FAQ.
                if (($foo)=$line=~/^To:\s+(.*)/i) {
                        my @toaddrs;
                        $foo=~s/"[^"]+"//g;   # Remove comments?
                        foreach my $addtest (split(/[,\s]+/, $foo)) {
                                $addtest=~s/^\s+//g; $addtest=~s/\s$//g;
                                next if (! $addtest);
                                if ($addtest=~/<(.*)>/) {
                                        push(@toaddrs, $1);
                                } elsif ($addtest=~/(\w+@[\w.]+)/){
                                        push(@toaddrs, $1);
                                } else {
                                        push(@toaddrs, $addtest);
                                }
                        }
                        $self->set_to([@toaddrs]);
                }
                if (($foo)=$line=~/^CC:\s+(.*)/i) {
                        my @toaddrs;
                        $foo=~s/"[^"]+"//g;   # Remove comments?
                        foreach my $addtest (split(/[,\s]+/, $foo)) {
                                $addtest=~s/^\s+//g; $addtest=~s/\s$//g;
                                next if (! $addtest);
                                if ($addtest=~/<(.*)>/) {
                                        push(@toaddrs, $1);
                                } elsif ($addtest=~/(\w+@[\w.]+)/){
                                        push(@toaddrs, $1);
                                } else {
                                        push(@toaddrs, $addtest);
                                }
                        }
                        $self->set_cc([@toaddrs]);
                }
                if (($foo,$bar)=$line=~/^From\s+(.*)\s+(\w{3}\s+\w{3}\s+\d+\s+\d+:\d+):\d+\s+\d+$/i) {
                        $self->set_date($bar);
                        $self->set_from($foo);
                }
                if (($foo)=$line=~/^Status:\s+(.*)/i) {
                        $foo=~/O/ and $self->set_neverseen(0);
                        $foo=~/R/ and $self->set_read(1);
                }
        }
        $self->set_deleted(0);
}
sub add_to_body {
        my $self=shift;
        push(@{$self->{body}}, @_);
}
sub _printablestatus {
        my $self=shift;
        return("X") if $self->is_deleted;
        return(" ") if $self->is_read;
        return("N") if $self->neverseen;
        return("U");
}
sub outputstatus {     # Why the hell mail uses one status flag in the file,
        my $self=shift; # and a _different_ one onscreen escapes me.  Lunacy.
        my $status;
        $status.="R" if $self->is_read;
        $status.="O";
        return($status);
}
# Given a message, return a 1 line summary, takes sequence # as arg
sub summary {
        my $self=shift;
        my $line=sprintf "%2s %2d %16s  %16s %3d/%4d ",
                $self->_printablestatus,
                $self->get_sequence,
                (defined $self->get_from) ? substr($self->get_from, 0, 16) : " ",
                (defined $self->get_date) ? $self->get_date : " ",
                $self->set_lines,
                $self->get_bytes;
        if (defined $self->get_subject) {
                $line.=substr($self->get_subject, 0, $main::COLS-length($line)-1);
        } else {
                $line.="(no subject)";
        }
        return($line);
}
sub printhead {
        my $self=shift;
        $self->set_read(1);
        return join("\n", grep(!/^Status:/i, @{$self->{head}}));
}
sub body {
        my $self=shift;
        $self->set_read(1);
        return join("\n", @{$self->{body}} );
}
sub whole {
        my $self=shift;
        my $lines=shift;
        $self->set_read(1);
        if (! defined $lines) {
                return  join("\n", grep(!/^Status:/i, @{$self->{head}}), "",@{$self->{"body"}});
        } else {
                return  join("\n", ( grep(!/^Status:/i, @{$self->{head}}), "",@{$self->{"body"}})[0..$lines] );
        }
}
1;
#
# Class to hold info about the mailbox.
#
package
        mailbox; # hide from PAUSE
use base 'PerlPowerTools::mailprog';
sub get_size { $_[0]->{'size'} }
sub get_file { $_[0]->{'file'} }
sub set_size { $_[0]->{'size'} = $_[1] }
sub set_file { $_[0]->{'file'} = $_[1] }
sub new {
        my $class=shift;
        my $self = {};
        if (@_) {
                my $a;
                while(defined ($a=shift)) {
                        $self->{$a}=shift;
                }
        }
        # Ok, this is here 'cause I want the displayed message numbers to
        # match the offsets in the array.  (Saves headaches later, believe it
        # or not.)
        @{$self->{messages}}="Invalid";
        bless($self, $class);
        return $self;
}
sub load {
        my $self=shift;
        print "Loading the mailfile ", $self->get_file, "\n";
        my $start=1;
        unless (defined $self->get_file) {
                die "No mailbox specified\n";
        }
        if (-d $self->get_file) {
                warn $self->get_file . ": is a directory\n";
                return;
        }
        unless (open MBOX, '<', $self->get_file) {
                warn $self->get_file . ": cannot open: $!\n";
                return;
        }
        $self->set_size(-s $self->get_file);
        my @MESS=();
        while(<MBOX>) {
                chomp;
                if (@MESS and /^From /) {
                        my $message=message->new;
                        $message->load_from_array(@MESS);
                        $message->set_sequence($start++);
                        push(@{$self->{messages}}, $message);
                        @MESS=();
                }
                push(@MESS, $_)
        }
        if (@MESS) {
                my $message=message->new;
                $message->load_from_array(@MESS);
                $message->set_sequence($start++);
                push(@{$self->{messages}}, $message);
        }
        close(MBOX);
        return 1;
}
sub stuff {
        my $self=shift;
        push(@{$self->{messages}}, $_[0]);
        $self->set_size(0);
}
sub write {
        my $self=shift;
        my $wa=shift;
        my $mode = exists $$wa{append} ? '>>' : '>';
        my $alt_msg="\"" . $self->get_file . "\" ";
        $alt_msg .= (-e $self->get_file) ? "[Appended]" : "[New File]";
        if (!open(MBOX, $mode, $self->get_file)) {
                warn "Failed to write to ", $self->get_file, ": $!\n";
                return;
        }
        my $bytes=(-s $self->get_file);   # cheat
        my $lines;
        foreach(1..$self->lastmsg) {
                my $message=$self->messagex($_);
                next if $message->is_deleted;
                if (! exists $$wa{bodyonly}) {
                        my $foo=$message->printhead;
                        print MBOX $foo, "\n";
                        $lines+=$foo=~tr/\n//;
                        print MBOX "Status: ", $message->outputstatus, "\n";
                        $lines+=1;
                }
                my $foo = $message->body;
                print MBOX "\n", $foo, "\n";
                $lines+=$foo=~tr/\n//;
                $lines+=2;
                if (exists $$wa{unread}) {
                        $message->set_read(0);
                }
        }
        close(MBOX);
        $bytes=(-s $self->get_file) - $bytes;
        $alt_msg.=" $lines/$bytes";
        return($alt_msg, undef);
}
sub messagex {
        my $self=shift;
        my $num=shift;
        return if $num <= 0;
        return(${$self->{messages}}[$num]);
}
sub replace {
        my $self=shift;
        ${$self->{messages}}[$_[0]]=$_[1];   # Replace that message
}
sub lastmsg {
        my $self=shift;
        return(scalar( @{$self->{messages}} )-1)
}
sub nextmsg {              # Returns sequence number of next (not deleted) message
        my $self=shift;
        my $current=shift;
        my $msg;
        while($msg=$self->messagex($current)) {
                if (! defined $msg) {
                        return undef;
                }
                if ($msg->is_deleted) {
                        $current++;
                        next;
                }
                last;
        }
        return($current);
}
1;
package
        editor; # hide from PAUSE
use base 'PerlPowerTools::mailprog';
use File::Temp;
sub get_message { $_[0]->{'message'} }
sub get_mesgno { $_[0]->{'mesgno'} }
sub set_message { $_[0]->{'message'} = $_[1] }
sub set_mesgno { $_[0]->{'mesgno'} = $_[1] }
sub new {
        my $class=shift;
        my $self = {};
        if (@_) {
                my $a;
                while(defined ($a=shift)) {
                        $self->{$a}=shift;
                }
        }
        bless($self, $class);
        return $self;
}
sub edit {
        my $self=shift;
        my $args=shift;
        my $msg = $self->get_message;
        if (! defined $msg) {
                die "Should Not Happen, edit without message";
        }
        if (exists $$args{subject}) {
                print "Subject: ";
                my $subj = <STDIN>;
                chomp $subj;
                $msg->set_subject($subj);
        }
        my($line,$tilde,$cmd,$arg);
        my @BODY;
EDLOOP: {
                $line=<STDIN>;
                if ( (not defined $line) or ($line=~/^\.\s+$/)) { last EDLOOP; }
                chomp $line;
                unless ( $line=~/^~[^~]/) {
                        $line=~s/^~+/~/g;   # Extra tildes changed to one.
                        push(@BODY, $line);
                        redo EDLOOP;
                }
                ($tilde,$cmd,$arg)=$line=~/(~)(.)\s*(.*)?/;
                warn "Bad line" if (! defined $tilde);
                $_=$cmd;
                SWITCH: {
                        /s/ && do { $msg->set_subject($arg); last SWITCH; };
                        /q/ && do { return; };
                        /\!/ && do { system($arg); last SWITCH; };
                        /c/ && do {
                                        my $ccs = $msg->get_cc;
                                        push(@{$ccs}, split(/[\s,;]+/, $arg));
                                        $msg->set_cc($ccs);
                                        last SWITCH;
                                };
                        /b/ && do {
                                        my $ccs = $msg->get_bcc;
                                        push(@{$ccs}, split(/[\s,;]+/, $arg));
                                        $msg->set_bcc($ccs);
                                        last SWITCH;
                                };
                        /t/ && do {
                                        my $tos = $msg->get_to;
                                        push(@{$tos}, split(/[\s,;]+/, $arg));
                                        $msg->set_to($tos);
                                        last SWITCH;
                                };
                        /m/ && do {
                                        my $msgs= main::parse_msg_list($arg, $self->get_mesgno);
                                        foreach(@$msgs) {
                                                my $rmsg=$main::box->messagex($_);
                                                next if (! defined $rmsg);
                                                push(@BODY, grep(s/^/> /g, split(/\n/, $rmsg->whole)));
                                        }
                                        last SWITCH
                                };
                        /f/ && do {
                                        my $msgs = main::parse_msg_list($arg, $self->get_mesgno);
                                        foreach(@$msgs) {
                                                my $rmsg=$main::box->messagex($_);
                                                next if (! defined $rmsg);
                                                push(@BODY, split(/\n/, $rmsg->whole));
                                        }
                                        last SWITCH;
                                };
                        /r/ && do {
                                open(F, '<', $arg) || do { warn "Unable to open $arg: $!\n"; last SWITCH; };
                                my $bytes=(-s $arg);
                                my(@FOO)=<F>;
                                close(F);
                                chomp(@FOO);
                                push(@BODY, @FOO);
                                print "read $arg $bytes bytes\n";
                        };
                        /v/ && do {
                                my $vipath = main::vipath() || last SWITCH;
                                my $tmp = File::Temp->new;
                                my $tmpfile = $tmp->filename;
                                @BODY=grep(s/$/\n/g, @BODY);
                                print { $tmp } @BODY;
                                my $rc = system($vipath, $tmpfile);
                                if ($rc != 0) {
                                        warn "Failed to execute '$vipath': $!\n";
                                        last SWITCH;
                                }
                                open(F, '<', $tmpfile) || die "Unable to re-open $tmpfile: $!";
                                @BODY=<F>;
                                chomp(@BODY);
                                close(F);
                                print "(Continued)\n";
                        };
                }
        redo EDLOOP;
        }
        $msg->add_to_body(@BODY);
        $self->set_message($msg);
        return($self->get_message);
}
1;
package main;
use File::Basename qw(basename);
use File::Spec;
use File::Temp;
use Getopt::Std;
use vars qw($opt_f $opt_s $opt_c $opt_b $opt_v);
our $VERSION = '0.05';
our $ROWS = 23;         # Screen Dimensions.  Yeah, this sucks.
our $COLS = 80;
our $BUFFERL = 2;         # Lines needed for "fluff"
my $Program = basename($0);
my $box;
my %commands=(
        "chdir"  => { alias => 'c',           args => 'path',                           },
        copy     => { alias => 'co',          args => 'msg,path', func => \&msg_copy    },
        "delete" => { alias => 'd',           args => 'msg',      func => \&msg_delete  },
        "exit"   => { alias => 'ex,x,xit',                        func => sub { exit; } },
        from     => { alias => 'f',           args => 'msg',      func => \&from        },
        headers  => { alias => 'h',           args => 'msg',      func => \&listing     },
        hold     => { alias => 'ho,preserve', args => 'msg',      func => \&unread      },
        mail     => { alias => 'm',           args => 'addr',     func => \&mail        },
        "next"   => { alias => 'n',                               func => \&msg_next    },
        "print"  => { alias => 'p',           args => 'msg',      func => \&msg_print   },
        quit     => { alias => 'q',                                     func => \&quit        },
        reply    => { alias => 'r',           args => 'msg',      func => \&replyCC     },  # Weird.
        Reply    => { alias => 'R',           args => 'msg',      func => \&reply       },
        save     => { alias => 's',           args => 'msg,path', func => \&msg_save    },
        shell    => { alias => 'sh',                                    func => \&shell       },
        top      => {                                             func => \&top         },
        undelete => { alias => 'u',           args => 'msg',      func => \&undelete    },
        unread   => { alias => 'U',           args => 'msg',      func => \&unread      },
        visual   => { alias => 'v',           args => 'msg',      func => \&visual      },
        "write"  => { alias => 'w',           args => 'msg,path', func => \&msg_write   },
);
$SET::toplines=5;
#
# Funcs which implement all that garbage above.
#
sub listing {
        my ($first)=@_;   # Pass in a mailbox, current message
        $first=$$first[0];
        foreach($first..$first+$ROWS-$BUFFERL) {
                my $message = $box->messagex($_);
                if (! defined $message) {
                        warn "Invalid message number: $first\n" if ($_ == $first);
                        last;
                }
                print $message->summary, "\n";
        }
        return $first;
}
sub vipath {
        return $ENV{'VISUAL'} if (defined $ENV{'VISUAL'});
        return 'vi';
}
sub shell {
        # How to get an interactive shell in Perl.  Hmmm...
        system("/bin/sh");   # For now.  :-)
}
sub mail {
        my($list,$mesgno)=@_;   # Target addresses
        my $msg=message->new;
        $msg->set_to($list);    # For whom the message tolls
        my $editor=editor->new;
        $editor->set_mesgno($mesgno);
        $editor->set_message($msg);
        $msg=$editor->edit({ subject => 1});
        if (! defined $msg) {
                print "Aborted\n";
                return;
        }
        my $mailer=mailer->new;
        $mailer->send($msg);
}
sub replyCC {
        my($list)=@_;   # Target addresses
        my(@ccaddrs, @replies, $subj, $tc);
        foreach(@$list) {
                my $original=$box->messagex($_);
                next if (!defined $original);
                if (! $subj) {
                        $subj = $original->get_subject;
                        unless ($subj=~/^re:/i) {
                                $subj="re: $subj";
                        }
                }
                push @replies, $original->get_from;
                $tc = $original->get_cc;
                push(@ccaddrs, @$tc) if $tc;
        }
        my $msg=message->new;
        $msg->set_to(\@replies);    # For whom the message tolls
        $msg->set_cc(\@ccaddrs);
        $msg->set_subject($subj);
        my $editor=editor->new;
        $editor->set_mesgno(@{$list}[0]);   # Use just the FIRST
        $editor->set_message($msg);
        print "To: ", join(',', @replies), "\n";
        if (@ccaddrs) {
                print "Cc: ", join(',', @ccaddrs), "\n";
        }
        print "Subject: $subj\n";
        $msg=$editor->edit;
        if (! defined $msg) {
                print "Aborted\n";
                return;
        }
        my $mailer=mailer->new;
        $mailer->send($msg);
}
sub reply {
        my($list)=@_;   # Target addresses
        my(@replies, $subj);
        foreach(@$list) {
                my $original=$box->messagex($_);
                next if (!defined $original);
                if (! $subj) {
                        $subj = $original->get_subject;
                        unless ($subj=~/^re:/i) {
                                $subj="re: $subj";
                        }
                }
                push @replies, $original->get_from;
        }
        my $msg=message->new;
        $msg->set_to(\@replies);    # For whom the message tolls
        $msg->set_subject($subj);
        my $editor=editor->new;
        $editor->set_mesgno(@{$list}[0]);   # Use just the FIRST
        $editor->set_message($msg);
        print "To: ", join(',', @replies), "\n";
        print "Subject: $subj\n";
        $msg=$editor->edit;
        if (! defined $msg) {
                print "Aborted\n";
                return;
        }
        my $mailer=mailer->new;
        $mailer->send($msg);
}
sub quit {
        if ( (-s $box->get_file) != $box->get_size ) {
                warn "Mail folder has changed size, not writing\n";
        }
        $box->write;
        exit;
}
sub visual {
        my($list)=@_;
        my $cmd = vipath() || return;
        foreach my $msgno (@$list) {
                my $message = $box->messagex($msgno);
                if (! defined $message) {
                        warn "Invalid message number: $msgno\n";
                        return;
                }
                my $tmp = File::Temp->new;
                my $path = $tmp->filename;
                my $tmbox = mailbox->new('file' => $path);
                $tmbox->stuff($message);
                $tmbox->write;
                my $rc = system($cmd, $path);
                if ($rc != 0) {
                        warn "Failed to execute '$cmd': $!\n";
                        return;
                }
                my $tmbox2 = mailbox->new('file' => $path);  # Hope this isn't a leak
                $tmbox2->load;
                $box->replace($msgno, $tmbox2->messagex(1));
        }
}
sub from {
        my ($list)=@_;
        my $lastgood;
        foreach my $msgno (@$list) {
                my $message = $box->messagex($msgno);
                if (! defined $message) {
                        warn "Invalid message number: $msgno\n";
                        return;
                }
                print "Message: ", $message->get_sequence, "\n";
                print $message->printhead, "\n";
                $lastgood=$msgno;
        }
        return $lastgood;
}
sub top {
        msg_print(@_, $SET::toplines);
}
sub msg_print {
        my ($list, $dummy, $nlines)=@_;
        my $lastgood;
        foreach my $msgno (@$list) {
                my $message = $box->messagex($msgno);
                if (! defined $message) {
                        warn "Invalid message number: $msgno\n";
                        return;
                }
                print "Message: ", $message->get_sequence, "\n";
                print $message->whole($nlines), "\n";
                $lastgood=$msgno;
        }
        return $lastgood;
}
sub unread { toggle(@_, 'unread'); }
sub undelete { toggle(@_, 'undelete'); }
sub msg_delete { toggle(@_, 'delete'); }
sub toggle {
        my ($msgs, $dumb, $option)=@_;
        foreach my $msgno (@$msgs) {
                my $message = $box->messagex($msgno);
                if (! defined $message) {
                        warn "Invalid message number: $msgno\n";
                        return;
                }
                if ($option eq 'unread') {
                        $message->set_read(0);
                }
                if ($option eq 'undelete') {
                        $message->set_deleted(0);
                }
                if ($option eq 'delete') {
                        $message->set_deleted(1);
                }
        }
        return;
}
sub msg_next {
        my($first)=@_;
        $first=$$first[0];
        my $nmsg=$box->nextmsg($first);
        if (! defined $nmsg) {
                warn "At EOF\n";
                return;
        }
        my $ret=msg_print([ $nmsg ]);
        return ++$nmsg if (defined $ret);
        return;
}
sub msg_save { msg_store(@_, { append => 1 }); }
sub msg_copy { msg_store(@_, { append => 1, "unread" => 1,} ); }
sub msg_write { msg_store(@_, { append => 1, bodyonly => 1,} ); }
sub msg_store {
        my($msgs, $file, $options)=@_;
        print "Saving message...$msgs to $file\n";
        my $tempbox=mailbox->new(file => $file);
        foreach my $msg (@$msgs) {
                my $message = $box->messagex($msg);
                if (! defined $message) {
                        warn "Invalid message number: $msg\n";
                        return;
                }
                $tempbox->stuff($message);
        }
        my($short, $long)=$tempbox->write( $options );
        print "$short\n";
}
#
# Helpers for Interactive();
#
sub parseargs {
        my($cmd, $mesgno)=@_;
        my($cref)=undef;
        my $word=$cmd;
        $word=~s/^([a-zA-Z]+).*/$1/;
        foreach (keys %commands) {
                if ($word eq $_) {
                        $cref=$commands{$_};
                } elsif (exists $commands{$_}{alias}) {
                        if (grep($word eq $_, split(/,/, $commands{$_}{alias}))) {
                                $cref=$commands{$_};
                        }
                }
        }
        return if (! defined $cref);
        if (! exists $$cref{args}) {   # No arguments to speak of.
                return($word, $$cref{func}, [ $mesgno ]);   # Always return current...
        }
        # Arguments.  Deal with them
        if ($$cref{args}=~/msg,path/) {  # Multiples
                my $list=$cmd;  $list=~s/^[a-zA-Z]+//g;
                my($arg1,$arg2)=$list=~/(.*)\s+([^\s+]+)$/;
                $arg1=parse_msg_list($arg1, $mesgno);
                return($cmd, $$cref{func}, $arg1, $arg2);
        }
        if ($$cref{args} eq 'addr') {
                my $list=$cmd;  $list=~s/^[a-zA-Z]+\s*//g;
                my @foo=split(/[\s,;]+/, $list);
                return($cmd, $$cref{func}, [ @foo ], $mesgno);
        }
        if ($$cref{args} eq 'msg') {
                # Remove the word at the beginning
                my $list=$cmd;
                $list=~s/^[a-zA-Z]+//g;
                my $msglist=parse_msg_list($list, $mesgno);
                return($cmd, $$cref{func}, $msglist);
        }
}
# Accepts empty, Accepts lists of space or comma-seperated numbers
# Accepts ranges (1-5), Accepts offsets (+1, -5), Special
# $=last message *=all messages
sub parse_msg_list {
        my($list, $current)=@_;
        $list =~ s/^\s+//g;
        $list =~ s/\s$//g;
        return [ $current ] if (length($list) == 0);
        # Get ugly.
        my @list=();
        foreach my $stuff (split(/[, ]+/, $list)) {
                $stuff="1-\$" if ($stuff=~/^\*$/);
                $stuff=~s/\$/($box->lastmsg)-1/e;
                push(@list, $stuff) if ($stuff=~/^\d+$/);
                push(@list, $1..$2) if ($stuff=~/^(\d+)-(\d+)/);
        }
        return(\@list);
}
#
# All of the interactive stuff is here...
#
sub Interactive {
        my($file)=@_;
        $box=mailbox->new(file => $file);
        if (! $box->load ) {
                print "You have no mail\n";
                exit;
        }
        my $current=1;
        select STDOUT; $|=1;
        my $cmd = "Init";
CMDS:   {
                if ($cmd eq "Init") {
                        $cmd="h";
                } else {
                        print "> ";
                        $cmd=<STDIN>;
                        $cmd = 'q' unless defined $cmd;
                        chomp $cmd;
                        $cmd =~ s/\A\s+//;
                }
        GOTONE: {
                        if ($cmd=~/^[a-zA-Z]+/) {
                                my ($fref, $arg1, $arg2);
                                ($cmd, $fref, $arg1, $arg2)=parseargs($cmd, $current);
                                if (! defined $cmd) {
                                        warn "Unknown command $cmd\n";
                                        redo CMDS;
                                }
                                if (! defined $fref) {
                                        warn "Unimplemented command $cmd\n";
                                        redo CMDS;
                                }
                                $current=&$fref($arg1, $arg2);
                                if (! defined $current) {
                                        $current=1;
                                }
                        } elsif ($cmd=~/^!(.*)/) {
                                system("$1");
                        } elsif ($cmd=~/^[0-9]/) {
                                $cmd="p $cmd";
                                redo GOTONE;
                        } elsif (! $cmd) {
                                $cmd="p";
                                redo GOTONE;
                        } else {
                                warn "Unknown command\n";
                        }
                }
                redo CMDS;
        }
}
sub debug {
        if ($opt_v) {
                print STDERR @_, (($_[$#_]=~/\n$/)?"":"\n");
        }
}
sub Batch {
        my $message=message->new;
        $message->set_to([@_]);
        $message->set_cc([ split(/,/, $opt_c) ]) if ($opt_c);
        $message->set_bcc([ split(/,/, $opt_b) ]) if ($opt_b);
        $message->set_subject($opt_s) if ($opt_s);
        my $mailer=mailer->new;
        my @BODY=<STDIN>;
        chomp(@BODY);
        $message->add_to_body(@BODY);
        $mailer->send($message);
}
sub VERSION_MESSAGE {
        print "$Program version $VERSION\n";
        exit;
}
sub usage {
        warn "usage: $Program [-s subject] [-c cc-addrs] [-b bcc-addrs] " .
            "to-addr ...\n       $Program [-f mailbox]\n";
        exit 1;
}
getopts('f:s:c:b:v') or usage();
if (@ARGV) {
        if (defined $opt_f) {
                warn "$Program: to-addr may not be specified with a mailbox\n";
                usage();
        }
        Batch(@ARGV);
} else {
        my $mbox = 'mbox';
        if (defined $opt_f) {
                $mbox = $opt_f;
        } elsif (exists $ENV{'MAIL'}) {
                $mbox = $ENV{'MAIL'};
        } elsif (exists $ENV{'HOME'}) {
                $mbox = File::Spec->catfile($ENV{'HOME'}, 'mbox');
        }
        Interactive($mbox);
}
HideShow 288 lines of Pod
=pod
=head1 NAME
mail - implementation of Berkeley mail(1)
=head1 SYNOPSIS
mail [B<-f> mailbox]
mail [B<-s> subject] [B<-c> cc-addrs] [B<-b> bcc-addrs] to-addr [..toaddr..]
=head1 DESCRIPTION
When called without command-line options (except B<-f>) I<mail> allows the user to
interactively send mail, and manage a mail folder.  Otherwise, I<mail> allows
the user to send outgoing E-mail to recipients.
When run interactively, the mail folder ~/mbox is used.  If the home
directory cannot be determined, ./mbox is assumed.  This can be overridden
with the B<-f> option.
=head2 OPTIONS
I<mail> accepts the following options
=over 4
=item B<-f> mailbox
Specifies a mail folder to use.
=item B<-s> subject
Specify a subject for the mail message.
=item B<-c> cc-addrs
A I<comma-separated> list of addresses to be copied to on the mail message.
=item B<-b> bcc-addrs
A I<comma-separated> list of addresses to be copied to on the mail message,
without appearing in the headers.
=item to-addr
E-Mail destination addresses.  You may not be notified if mail fails to
deliver to the address properly.
=back
=head2 COMMANDS
In the list below, "msg" indicates a message list.  Acceptable values are comma or
space separated lists, ranges (i.e. 1-5) or single digits.  Special values are "$"
(end of list) and * (all messages).  If messages are unspecified, the current message
is used.  "path" indicates a filename argument.  "addr"
indicates a mail message address list (comma or space separated).
=over 4
=item number
Read message I<number>.
=item !command
Execute the "command" with the command interpreter.
=item copy msg path
Copy indicated messages (I<msg>) to filename at I<path>.
B<co> is an alias for this command.
=item delete msg
Delete indicated messages.
B<d> is an alias for this command.
=item exit
Exit the I<mail> program saving no changes to the mailbox.
B<x> is an alias for this command.
=item from msg
Display the headers from the specified messages.
B<f> is an alias for this command.
=item headers msg
Display a brief list of headers from the messages.
B<h> is an alias for this command.
=item hold msg
Mark messages as unread.  B<ho,preserve> are aliases for
this command.
=item mail addr
Send a mail message to addr.  B<m> is an alias for this command.
=item next
Print the next message in sequence.  B<n> is an alias for this command.
=item print msg
Print the specified mail message.  B<p,CR> are aliases for this command.
=item quit
Exit the mail program.  The (possibly) edited mailbox is re-written to
its original file.  See B<Bugs>.  B<q> is an alias for this command.
=item reply msg
Reply to the original sender of I<msg>.  B<r> is an alias for this command.
=item Reply msg
Reply to the original sender, and all visible recipients of I<msg>.
B<R> is an alias for this command.
=item save msg path
Save I<msg> into the file specified at I<path>.  If the file exists, it
is appended.  B<s> is an alias for this command.
=item shell
Start an interactive I<bourne> shell.  (This does not work under Win32).
B<sh> is an alias for this command.
=item top
Display the first few lines of the current mail message.
=item undelete msg
Mark as undeleted any specified mail messages.
B<u> is an alias for this command.
=item unread msg
Mark as unread any specified mail messages.
B<U> is an alias for this command.
=item visual msg
Invoke the visual editor (specified in $VISUAL, or /usr/bin/vi) on the
indicated messages.  Re-read those messages in after the editing session.
B<v> is an alias for this command.
=item write msg path
Write the I<bodies> of the indicated messages to path.
B<w> is an alias for this command.
=back
=head2 EDITING COMMANDS
When sending a mail message (commands B<mail, reply or Reply>) a primitive
line-mode editor is used to get the body of the mail message, and possibly
change any header options.  During the editing session, special commands may
be used when typed at the beginning of the line.
To send the message, send an EOF character or a "." on a line by itself.
=over 4
=item ~ssubject
Change message subject to I<subject>.
=item ~q
Quit the message editor.  No changes are made, no message is sent.
=item ~caddr[,addr...]
Add the I<addr>s to the CC list for the message
=item ~baddr[,addr...]
Add the I<addr>s to the BCC list for the message
=item ~taddr[,addr...]
Add the I<addr>s to the To: list for the message
=item ~mmsg
Read the specified messages into the current message at the end.
=item ~fmsg
Read the specified messages into the current message at the end,
indenting each line with the sequence "> ".
=item ~rfile
Read the contents of I<file> into the message.
=item ~v
Invoke the visual editor on the message.  When the user is done
editing the message, read the message back in, and continue editing
at the end.
=back
=head1 BUGS
Numerous.  Mostly lack of refinement in the implementation, any of
which can be fixed without hassle, I'm sure.
=over 4
=item *
Many (many, many..) features left unimplemented.  Command-line,
commands and editing functions have all been decimated. I only implemented what
I thought was useful.  I<BSD mail> had many years to develop its many
tentacles.  I don't have that kind of patience.
=item *
Keeping track of the "current" message in the mail folder is sloppy.
=item *
Screen length is assumed to be 23 characters.  Width is 79.
=item *
Argument parsing doesn't ensure sane (and legal) combinations.
=item *
There is B<no> file locking.  Of anything.  You wanna re-write the
mailbox and there's local delivery going on?  Fine.  Have fun.  I<mail>
will refuse to write back a mailbox whose size has changed however...
=item *
I<mail> doesn't act as a Local Delivery Agent.
=item *
I<mail>'s method of picking through mail message headers to find from, to
and cc addresses violates several FAQ's, RFC's, and is void where prohibited.
Also easy to fix, I simply ran out of patience.  See the _extract method in the
message class if you're adventuresome.
=item *
To perform delivery, mail searches for C<$USER> or C<$LOGNAME> in your environment to see who
you are (for a From address).  It then searches for an SMTP agent on localhost.
Not finding that, it wants $RELAYHOST set to your SMTP relaying host name.  Your
reply address is taken from $REPLYADDR or your system's environment.  Whichever
is easier.  Win32 systems, be prepared to setup your environment properly for
this to work!
=item *
...speaking of SMTP... I<mail> talks directly to SMTP instead of using a more
sane method like Mail::Mailer.  This was done so that PPT mail(1) could remain
"pure" and un-encumbered by external modules.
=back
=head1 AUTHOR
The Perl implementation of I<mail> was written by
Clinton Pierce, I<clintp@geeksalad.org>.
=head1 COPYRIGHT and LICENSE
This program is Copyright 1999, by Clinton Pierce.
Freely redistributable under the Perl Artistic License.
=cut
1;