#!/usr/bin/perl 
# $Id: yample,v 1.35 2004/01/13 22:32:04 perbu Exp $

our ($VERSION);
$VERSION = '0.30';

=head1 NAME

Yample - Yet Another Mail Processing Language.

=head1 DESCRIPTION

Yample is an MDA - a mail delivery agent. It accepts a message via
standard input and stores this message in a maildir or in a mbox.

Yample tries to incorporate the power of Perl and Mail::Internet,
Mail::Spamassassin and the other Mail modules whilst maintaining an
friendly syntax. Yample was written due to a personal conflict with
Procmails syntax.

Look at the following lines, taken from "man procmailex";

:0 c
* ^From.*peter
* ^Subject:.*compilers
! william@somewhere.edu

  :0 A
  petcompil

This can be implemented like this in Yample;

sender(peter) and subject(compilers) unseen resend(william@somewhere.edu)
sender(peter) and subject(compilers) mbox(petcompil)

=cut

# load critical modules. Without these - we fail.

use strict;

use Mail::Internet;
use Mail::Send;

use Getopt::Long;
use Pod::Usage;

#use Regexp::Common qw(balanced);
use Text::Balanced qw(extract_bracketed);

# use Data::Dumper;

$SIG{__DIE__} = sub { DB::backtrace() };

use constant    OK     => 1;
use constant    FAILED => 0;
use constant    TEMPFAIL => 101;
use constant    PERMFAIL => 75;

use constant    RX_MAGIC => 1;
use constant    LIST_SUPPORT => 1;

use constant    S_COND   => 0;
use constant    S_ACTION => 1;

my $HOME = $ENV{'HOME'};
my $BASE = "$HOME/.yample";

my (@RULES);

my $HELP;
my $SHOW_VERSION;
my $MAILBASE     = "$HOME/Maildir";
my $LOGFILE      = "$BASE/log";
my $RULESFILE    = "$BASE/rules";
my $DUPDB        = "$BASE/dupdb";
my $LOGLEVEL     = 1;
my $SPAMASSASSIN = 0;
my $SPAMC        = 0;
my $SPAMC_PATH   = "spamc";
my $PANIC_MBOX   = "$BASE/panic_mbox";
my $DRY_RUN      = 0;


=head1 OPTIONS

=over 5

=item B<--help>

Help!

=item B<--mailbase <maildir>>

This option is prepended to any destinations you have. Default is
~/Maildir/.

=item B<--logfile>

Yamples logfile. Default is ~/.yample/log.

=item B<--loglevel <0-4>>

Loglevel. 4 - Debug, 3 - info, 2 - warnings, 1 - errors, 0 - nothing.

=item B<--spamassassin>

Load Mail::Spamassassin and run the mail through it.

=item B<--spamc>

Run the message through spamc. Yample will look for spamc in the $PATH
unless you set B<--spamc-path>.

=item B<--spamc-path> /path/to/spamc

Where spamc resides.

=item B<--dubdb <file>>

The message id database - used for duplicate suppression.

=item B<--rules <file>>

The rule file.


=back

=head1 FILES

=head2 ~/.yample/rules

This file contains the rules which Yample uses to sort mail. Yample
reads the mail from STDIN and then processes the rules, one by one.

The rules consists of two parts; condition(s) and target. There is an
implicit if .. then .. else between every rule. Please see the
examples futher down.


In the conditions which take a regular expression as a parameter you can
use grouping to extract parts of the text and utilize this in the
sorting. Like this: "subject((.*)) and rcpt(user@foo.org): reject(Your
message with subject $1 was rejected)". Cool, eh?

NOTE: We replace "/" and "." with "_" in grouped strings to make sure
there won't be any funny business.

=over 5

=cut



GetOptions(
    "help"         => \$HELP,
    "version"      => \$SHOW_VERSION,
    "mailbase=s"   => \$MAILBASE,
    "basedir=s"    => \$BASE,
    "logfile=s"    => \$LOGFILE,
    "loglevel=i"   => \$LOGLEVEL,
    "dupdb=s"      => \$DUPDB,
    "spamassassin" => \$SPAMASSASSIN,
    "spamc"        => \$SPAMC,
    "spamc-path"   => \$SPAMC_PATH,
    "dry-run"      => \$DRY_RUN,
    "rules=s"      => \$RULESFILE,
  )
  or pod2usage(
    -msg     => "$!    Type $0 --help for help",
    -exitval => 1,
    -verbose => 0,
    -output  => \*STDERR
  );

if ($HELP) {
    pod2usage(
        -msg     => 'Try "perldoc yample" for a in-depth description',
        -exitval => 0,
        -verbose => 1,
        -output  => \*STDOUT
    );
}

if ($SHOW_VERSION) {
    print("$VERSION");
    exit;
}

my $logger = new Yample::Logger( $LOGFILE, $LOGLEVEL );

$logger->log( 3, "hi! Yample $VERSION is starting up." );

if ( $SPAMC && $SPAMASSASSIN ) {
    $logger->log( 1,
        "Both spamc and spamassassin are enabled - disabeling spamassassin" );
    undef $SPAMASSASSIN;
}


@RULES = getsortinglist();


my $yample = Yample::Mail->new( 'emergency'         => $PANIC_MBOX, 
                                'dupdb'             => $DUPDB,
                                'logger'            => $logger,
                                'SPAMC'             => $SPAMC,
                                'SPAMASSASSIN'      => $SPAMASSASSIN,
				);

# we are not spam - sort the mail.

# first sort out the mailing lists (rcptlist)

# Rules:


my %CONDITIONS = 
  (
   'sender'   => \&Yample::Rules::sender,
   'rcpt'     => \&Yample::Rules::rcpt,  
   'subject'  => \&Yample::Rules::subject,
   'list'     => \&Yample::Rules::list,
   'spam'     => \&Yample::Rules::spam,
   'head'     => \&Yample::Rules::head,
   'dup'      => \&Yample::Rules::dup,
   'perl'     => \&Yample::Rules::perl,
);   

# print (Dumper(\@RULES));

# prepare a dispatcher:

my $dispatcher = new Yample::Actions ( $logger );


RULELIST: for my $rule (@RULES) {
    $logger->log(3, "Trying rule line # $rule->{line}");

    my ($result, @matches) =  try_rule($rule) ;
    
    if ($result) {
        my $target = $rule->{parameter};

        if ($target =~ s/\$(\d)/$matches[$1 - 1]/eg) {
            $logger->log(3, "target altered: $rule->{parameter} --> $target");
        }

        $logger->log(1, "\#$rule->{line} $yample->{msg_id}/$yample->{subject}:  $rule->{action}($target)");

        
        $dispatcher->dispatch($rule->{action}, 
                              $target, @matches )
          unless ($DRY_RUN);
        
        if ($rule->{unseen}) {
            $logger->log(3, "Unseen delivery - will continue");
        } else {
            done();
        }
        
    } else {
        
    }

}

#  try_rule($)

# The while-loop marked RULELIST traverses the rules and passes them
# them to this subqroutine which decides whether they match or not.


sub try_rule {
    my ($rule) = @_;
    my $result = 0; # we default to 0 - "false";
    my @expr;
    my @rules_matches;

    for my $condition ( @{ $rule->{cond} } ) {

	if (ref $condition) {


            my ($action, $parameter) = @{ $condition };

            if (defined($CONDITIONS{$action})) {
                my ($result, @matches) =
                  &{ $CONDITIONS{$action}}( $yample, $parameter);

                # strip off unsafe characters
                for (@matches) {s,[/.],_,g; }

                push(@expr, $result || '0');

                $logger->log(3, "$action($parameter) --> $result");

                push(@rules_matches, @matches);

            } else {
                STDERR->print("Undefined condition: $action\n");
            }
        } else {

	    if ($condition eq 'and'  or $condition eq 'or' 
		or $condition eq ')' or $condition eq '(' 
		or $condition eq '!'
		) {
		push( @expr, $condition);
	    } else {

		# parser error

	    }
	}
    }

    my $expr = join(' ', @expr);

    my $result = eval( $expr );
    $logger->log(3, "eval($expr) ---> $result");
    
    if ($@) {
        $logger->log(0, "Rule on line $rule->{line}: Eval of '$expr' failed - $@");
    }
    return($result, @rules_matches);
}


$logger->log(1, "There was no rule to catch this mail - storing i PANIC MBOX ($PANIC_MBOX)");

$dispatcher->dispatch('mbox', $PANIC_MBOX)
  unless $DRY_RUN;

done();

# done()
#
# Ends the program in a controlled fashion.


sub done {
    $logger->log(3, "Yample is about to exit in an orderly fashion");
    $logger->close;
    exit(0);
}


# match_replace($target, @matches)
#
# match_replace does the search and replace on the target.

sub match_replace {
    my ( $target, @matches ) = @_;

    $logger->log( 3, "s/r on $target" );
    if ( $target =~ s/\$(\d)/$matches[$1 - 1]/eg ) {
        $logger->log( 3, "target altered: now $target ($1 $2 $3 $4)" );
    }
    return $target;
}

# getsortinglist()

# sub getsortinglist reads ~/.yample/rules or whatever you spesify,
# parses the rules and creates a list. The parser is a bit buggy - it
# does not handle the rules properly - but it will cover 99.9% of your
# needs, methink. Please let me know if you find a bug.


sub getsortinglist {
    my ($list) = @_;
    my @LIST;
    
    my $LIST = new IO::File($RULESFILE)
	or $logger->log( 2, "Could not open rules($RULESFILE): $!" );
    
    while ( my $line = <$LIST> ) {
        next if ( ( $line =~ m/^\s*\#/ ) or ( $line =~ m/^\s*$/ ) );

        chomp($line);
        # ryletype(parameters): [unseen] ACTION(parameter)
	my (@cond, $unseen, $ac, $ac_par);

	my $state = S_COND;
	
	while ($state == S_COND) {

	    if ($line =~ m/^\s*(\w+)(\(.*)/) {
		my ($cmd, $par) = ($1, $2);
		$line = $par;
		# $1 is the command
		# $2 is probably the parameter + $line
		
		my ($extracted, $remainder) =
		    extract_bracketed( $line,'()');

		$line = $remainder;
		
		# print "cmd: '$cmd' - '$extracted' - '$line'\n";

		push(@cond, [$cmd, $extracted] );
		
	    } elsif ( $line =~ m/^\s*(and|or|\!|\(|\))(.*)/) {
		push(@cond, $1);
		$line = $2;
	    } elsif ($line =~ m/^:\s*(.*)/) {

		$line  = $1;
		$state = S_ACTION;
	    }

	    # print "After pop: $line\n";
	}

	if ($line =~ m/unseen\s+(.*)/ ) {
	    $unseen = 1;
	    $line = $1;

	} 

	if ($line =~ m/(\w+)\((.*)\)/ ) {
	    ($ac, $ac_par) = ($1, $2);

	    
	} else {
	    # parse error.
	    next;
	}
	
	# \( ([^\\)] | \\| \) )* \)
	# print "Cond: $1\n";
            
	my $rule = {
	    'cond'      => \@cond,
	    'unseen'    => $unseen,
	    'action'    => $ac,
	    'parameter' => $ac_par,
	    'line'      => $LIST->input_line_number(),
	};

	push( @LIST, $rule );

    }

    $LIST->close();
    return @LIST;
}


=item Yample::Rules

This package contains subroutines which handle the individual
rules. The rules are transformed into perl code which will call these
methods to decide what to do with the message. 

=cut 

package Yample::Rules;

use IO::File;
use POSIX;

=item dup()

Detects duplicates.

=cut

sub dup {
    my ($yample) = @_;

    return $yample->{dup};
}

=item rcpt()

The rcpt rule matches against the To- and Cc-headers.

=cut

sub rcpt {
    my ($yample, $rx) = @_;

    my @matches;

    if ( ( @matches = $yample->to =~ m/$rx/i ) 
         or ( @matches = $yample->cc =~ m/$rx/i ) ) {
        
        return(1, @matches);
        
    } else {
        return undef;
    }
}

=item sender()

The sender rule matches against the From-header.

=cut

sub sender {
    my ($yample,$rx) = @_;

    my @matches;

    if ( @matches = $yample->from =~ m/$rx/i ) {

        return(1, @matches);
        
    } else {
        return undef;
    }
}


=item subject()

Matches on the subject of the message.

=cut

sub subject {
    my ($yample, $rx) = @_;
    my @matches;

    if ( @matches = $yample->subject =~ m/$rx/i ) {
        return(1, @matches);
    } else {
        return undef;   
    }

}

=item list()

If Yample can load Mail::Listdetect then list() can be used to match
against the name of the mailing list (unless the mailing list server
is completely lame). 

You can use this rule like this:

list((.*)):      maildir(.lists.$1) 

=cut


sub list {
    my ($yample, $rx) = @_;
    my @matches;

    if ( $yample->listname and ( @matches = $yample->listname =~ m/$rx/i ) ) {
        return(1, @matches);
    } else {
        return undef;   
    }

}

=item head() 

Match against a arbitrary header. Note the caret (^) 

head(^X-Spam-Flag: YES):               maildir(.junk.spam)
head(^X-Infected:):                    maildir(.junk.virii)

=cut

sub head {
    my ( $yample, $rx ) = @_;
    my @matches;

    if ( @matches = ($yample->{head} =~ m/$rx/smi ) ) {
        return(1, @matches);
    } else {
        return undef;
    }
}

=item spam()

If Yample loads Spamassassin (and runs the message through it) you can
use spam() to determine the status of the message.

=cut

sub spam {
    my ($yample) = @_;
    
    return ( $yample->sa_status );
}

=item perl()

Run arbitrary perl code. Unless you are some sort of pervert you would
not use this for anything but testing and debugging Yample.

=cut

sub perl {
    my ($yample, $expr, @matches) = @_;
    my @ret = eval($expr);
    if ($@) {
	$yample->logger->log(1,
			     "perl($expr) yielded an error: $@");
    }
    return( @ret );

}


=item Yample::Actions

Action dispatcher class. All the targets are defined here.

=cut 


package Yample::Actions;

# new()
#
# new() sets up the Action class (logging and such).


use Fcntl ':flock';               # import LOCK_* constants
use IO::File;
use Sys::Hostname;


sub new {
    my ($self, $logger) = @_;

    $self = {};

    bless $self;
    
    $self->{logger}  = $logger;
    $self->{actions} = actions();

    return $self;
}

# dispatch()
#
# Dispatcher - call the apropiate subroutine.


sub dispatch {
    my ($self, $action, $parameter) = @_;

    $self->{logger}->log(3, "Dispatching $action ($parameter)");

    &{ $self->{actions}->{$action} }( $self, $parameter );

    return $self;
}

# actions()

# Defines the different actions.


sub actions {

    my %ACTIONS = (
                   maildir => \&maildir,
                   mbox    => \&mbox,
                   resend  => \&resend,
                   ignore  => \&ignore,
                   reject  => \&reject,
                   reply   => \&reply,
                   pipe    => \&pipe,
                  );
    
    return \%ACTIONS;
}

=item maildir()

Stores the message in a UW-style maildir more or less as defined per
RFCXXXX.

=cut

sub maildir {
    my ($self, $dest) = @_;
    $dest = '' unless ($dest);

    my $folder;

    if ($dest =~ m,^[/~],) {
        $dest =~ s/^~/$ENV{HOME}/e;
        $folder = $dest;
    } else {
        $folder = "$MAILBASE/$dest";
    }

    "$MAILBASE/$dest";

    $self->{logger}->log( 3, "Storing message in Maildir $folder" );
    
    if ( -f $folder ) {
        $self->{logger}->log( 1,
                              "$folder is not a directory - it is a file - we will pretend it is a mbox"
			      );
	
	$self->mbox($dest);

    }
    elsif ( !-d $folder ) {
        $self->{logger}->log( 1, "No maildir found, creating $folder/(cur|new|tmp)" );
        
        mkdir("$folder", 0700) ||
          $self->{logger}->log( 1, "Unable to create directory $folder: $!" );
        mkdir("$folder/cur", 0700) ||
          $self->{logger}->log( 1, "Unable to create directory $folder $!" );
        mkdir("$folder/new", 0700) || 
          $self->{logger}->log( 1, "Unable to create directory $folder/new: $!" );
        mkdir("$folder/tmp", 0700) ||
          $self->{logger}->log( 1, "Unable to create directory $folder/tmp: $!" );
    }

    # here we do the maildir delivery.
    my $fname = time() . ".$$." . hostname();

    $self->{logger}->log(3, "Creating $folder/tmp/$fname");

    my $target = IO::File->new("$folder/tmp/$fname", 
			       O_CREAT|O_WRONLY|O_APPEND);

    unless (defined $target) {
	$self->{logger}->log(1, "Could not create '$folder/tmp/$fname': $!");
	exit(main::TEMPFAIL);
    }

    $yample->print( $target );
    $target->close();
    
    unless ( link("$folder/tmp/$fname", "$folder/new/$fname")) {
	$self->{logger}->log(1, "linking of '$folder/tmp/$fname' failed: $!");
	exit(main::TEMPFAIL);
    }
    
    unless (unlink("$folder/tmp/$fname")) {
	$self->{logger}->log(1, "Unlink of '$folder/tmp/$fname' failed: $!");
	exit(main::TEMPFAIL);
    }

    $self->{logger}->log(3, "linked into  $folder/new/$fname");

}

=item mbox()

Delivers mail to a standard Unix mailbox.

Parameters: The mailbox where the message is to be delivered.

=cut

sub mbox {
    my ($self, $dest) = @_;
    my $folder;

    if ($dest =~ m,^[/~],) {
        $dest =~ s/^~/$ENV{HOME}/;
        $folder = $dest;
    } else {
        $folder = "$MAILBASE/$dest";
    }

    $self->{logger}->log( 3, "Storing in mbox '$folder'");

    unless ( -f $folder ) {
        $self->{logger}->log( 3, "No mbox found, creating" );

    }
    if ( -d $folder ) {
        $self->{logger}->log( 1,
                              "$folder is a maildir - not a mbox - we will attempt Maildir-delivery"
			      );
	$self->maildir($dest);
	
    } else {
	# mbox delivery.
	
	my $locked = 0;
	
	my $mbox = new IO::File(">> $folder");

	for my $i (0 .. 9) {
	    if ( flock($mbox, LOCK_EX ) ) {
		$locked++;
	    } else {
		# pick a number, any number.
		sleep(6);
	    }

	}
	
	if (! $locked) {

	    $self->{logger}->log(5, "Could not aquire lock");
	    exit(main::TEMPFAIL);

	} else {

	    $mbox->seek(2,0);
	    $yample->print( $mbox );

	}

    }
}

=item resend()

Parameters: Where the message is to be forwarded. 

=cut


sub resend {
    my ($self, $dest) = @_;
    $self->{logger}->log( 3, "Resending mail to '$dest'");

    # fixme: borken? Maybe not by SMTP?
    $yample->smtpsend( To => $dest );

}

=item reject()

Reject the message. This normally forces your mail server to create a
bounce and mail this to the original sender. 

Parameters: Error message. This message will probably be included in
the bounce generated.


=cut

sub reject {
    my ($self,  $reason) = @_;
    $self->{logger}->log( 3, "Rejecting mail; '$reason'");

    STDERR->print(
                  "Rejecting message: \n",
                  $reason, "\n",
                  );
    exit(main::PERMFAIL);
}

=item ignore()

Ignore the message silently.

Parameters: none

=cut

sub ignore {
    my ($self) = @_;
    $self->{logger}->log( 3, "Ignoring mail");

    # uuhh. no-op.
}

=item reply()

Reply to the message.

Parameters: The body of the reply.

=cut

sub reply {

    my ($self, $body) = @_; 



    if ($self->head->as_string =~ m/(^(
				       (
					(Mailing-List|Precedence):.*
					(junk|bulk|list)
					) 
				       |
				       (
					(From|Sender|X-Envelope-From):.*
					(post(master|office))
					)
				       )
				     )/xi) {
	$self->{logger}->log( 1, "Skipping reply - from postmaster.");
	
    } else {
	
	my $rcpt =  $self->head->get("Resent-From")
	    || $self->head->get("Reply-To")
	    || $self->head->get("Return-Path")
	    || $self->head->get("From")
	    || $self->head->get("Sender");

	
	$self->{logger}->log( 3, "Sending replay to $rcpt '$body'");
	
	my $msg = new Mail::Send( Subject => "Re: ". 
				  ($self->subject) ? $self->subject : 'your message',
				  To => $self->from);
    
	my @references;
	
	@references = ( split(' ', $self->head->get("References")), 
			split(' ', $self->head->get("Message-ID")));
	
	@references = grep { /^<.*>$/ } @references;
	
	$msg->set('References', join(' ',@references));
	
	my $fh = $msg->open();
	
	$fh->print($body);
	$fh->close();
	
    }
}



=item pipe()

Parameters: The command which is message is to be piped into. Executed
through "/bin/sh -c".

=cut

sub pipe {
    my ($self, $program) = @_;

    $self->{logger}->log( 3, "Piping to '$program'");
    open(PIPE, "|$program");

    $yample->print( \*PIPE );

    close PIPE;

    my $status = ($? >> 8);

    if ($status != 0) {	
	$self->{logger}->
	    log(1, "'$program' returned non-zero value ($status)");
    }

}


package Yample::Mail;

# is you get dups with more than 2000 other messages inbetween - increase this.
# (as if)

use constant MAX_DUPDBSIZE => 2000;
use Fcntl;

# use Data::Dumper;

use IPC::Open2;
use Mail::Internet;
use vars qw (@ISA $AUTOLOAD);

@ISA = 'Mail::Internet';

# The mail object and everything releated to the email is stored here.
sub new {
    my ($self, %OPTS ) = @_;

    #my $mail   = 
    #
    #				     );
    $self = Mail::Internet->new( \*STDIN );
    bless $self;
    
    @ISA = 'Mail::Internet';

    $self->{logger}    = $OPTS{logger}; 


    $self->{encoding}  = $self->get("Content-Transfer-Encoding");

    $self->{to}        = $self->head->get('To:');
    $self->{cc}        = $self->head->get('Cc:');
    $self->{from}      = $self->head->get('From:');
    $self->{subject}   = $self->head->get('Subject:');

    $self->{msg_id}    = $self->head->get("Message-Id");

    $self->{head}      = $self->head->as_string();

    if ($self->{encoding}) {
        eval {
            require MIME::Words;
            import MIME::Words qw(:all);
        };
	$self->{logger}->log(1, "Error while loading MIME::Words: '$!'")
	    if ($@);
    }
    
    
    for ( qw(from subject to cc ) ) {
        chomp($self->{$_});
	if ($self->{encoding}) {
	    $self->{$_} = decode_mimewords($self->{$_});
	}
    }

    $self->{listname}  = listdetect( $self );

#     $self->{dup}       = 0;
    $self->{dup}       = is_dup($self->{msg_id}, $OPTS{dupdb});
    
    $self->{logger}->log(3, "Dup: " . $self->{dup} );


    # do SA-stuff:
    $self->{sa_status} = undef;
    if ( $OPTS{SPAMC} ) {
	$self->{sa_status} =  $self->do_spamc();
    } elsif ($OPTS{SPAMASSASSIN} ) {
	$self->{sa_status} = $self->do_sa();
    }
    
    return $self;
}

sub AUTOLOAD {
    my ($self, @args) = @_;

    my @name = split(/::/, $AUTOLOAD);
    my $method = pop(@name);
    return if $method eq 'DESTROY';

    return $self->{$method};

}


# this a blatant rip out of Mail::Audit::KillDups. I needed to change it
# a bit. This code is (c) Simon Cozens <simon@cpan.org>

sub is_dup {
    my ($mid, $dupdb) = @_;
    my $end_of_ring = 0;
    my $current_pos;

    chomp $mid;
    unless ( sysopen( MSGID, $dupdb, O_RDWR | O_CREAT ) ) {
        return 0;
    }

    while (<MSGID>) {
        chomp;

        if ( $_ eq $mid ) {

            # found it.
            return 1;
        }

        $current_pos = tell MSGID;
        if ( $current_pos > MAX_DUPDBSIZE && $end_of_ring == 0 ) {

            # we've gotten too big, write this mid back at the top of the file
            last;
        }
        elsif ( $_ eq "" && $end_of_ring == 0 && $current_pos > 0 ) {

            # Found the end of the ring buffer, so save position.
            $end_of_ring = $current_pos - 1;
        }
    }

    # Didn't find mid, so write it to the end of the ring buffer
    unless ( seek MSGID, $end_of_ring, 0 ) {
        close MSGID;
        return 0;
    }

    print MSGID "$mid\n\n" unless ($DRY_RUN);
    close MSGID;

    return 0;
}

# end of rip-out :)

sub listdetect {
    my ($mail) = @_;
    my $listname;

    return undef unless (main::LIST_SUPPORT);

    eval {
        require Mail::ListDetector;
        import Mail::ListDetector;
        my $listdet = new Mail::ListDetector($mail);
        $listname = $listdet->{data}->{listname};
        unless ($listname) {
            my $post_addr = $listdet->{data}->{posting_address};
            if ($post_addr) { 
                ($listname) = $post_addr =~ m/(.*)@/
            }

        }
    };

    if ($@) {
        warn("Could not load Mail::ListDetector: $@" );
        return undef;
    } else {
        return $listname;
    }
}



sub do_spamc {
    my ($self) = @_;
    my ($rfh, $wfh, $sa_status );

    $self->{logger}->log( 3, "Starting spamc" );

    if ( open2( $rfh, $wfh, "/usr/bin/spamc -c" ) ) {
        $wfh->print( $self->as_string() );
        $wfh->close();
        while (<$rfh>) {
            $sa_status .= $_;
        }
        
        $sa_status =~ s,/.*,,;

        $wfh->close();

        $self->{logger}->log(1, "Spamc score: $sa_status");
        return($sa_status);

    } else {
        $self->{logger}->log(1, "Problem running spamc: $!");
        return undef;
    }

}


sub do_sa {
    my ($self) = @_;

    my ($sa_status);

    $self->{logger}->log( 3, "Loading SA" );

    eval {
        require Mail::SpamAssassin;
        import Mail::SpamAssassin;
    };

    if ($@) {
        $logger->log( 1, "Coult not load Mail::SpamAssassin: $@" );
        return undef;
    }
    else {
        $logger->log(3, "SA loaded OK");
    }

    my $spamassassin = Mail::SpamAssassin->new();

    my $msg_rep      = $spamassassin->check( $self );
    
    if ( $msg_rep->is_spam() ) {
        $sa_status = $msg_rep->get_hits();
        $msg_rep->rewrite_mail();
        $self->{logger}->log(1, "Spamassassin score: $sa_status");
        return $sa_status;
    } else {
        return undef;
    }
}


package Yample::Logger;

use IO::File;
use Fcntl;
use POSIX qw(strftime);


sub new {
    my ($self, $filename, $loglevel) = @_;

    $self = {};
    bless $self;

    my $FD = new IO::File;

    $FD->open( $filename, O_WRONLY | O_APPEND | O_CREAT, 0600 )
      or warn "Unable to open log ($LOGFILE: $!";
    $FD->autoflush(1);
    
    $self->{FD} = $FD;
    $self->{loglevel} = $loglevel;

    return $self;
}

sub log {
    my ( $self, $level, @msg ) = @_;
    chomp(@msg);

    # high numbers are less important.

    return if ( $level > $self->{loglevel} );

    my $now = strftime "%F %T", localtime;

    $self->{FD}->printf( "%s (pid:%6i,level:%-2i) - %s\n",
                         $now, $$, $level, join( '', @msg ), "\n" );
}


sub close {
    my ($self) = @_;
    
    $self->{FD}->close();
}


package DB;
                                                                                                             
sub log_error {
    STDERR->print(@_, "\n");
}
                                                                                                             
sub backtrace {
  my ($file, $line) = (__FILE__, __LINE__);
  my $msg = "@_"; chomp($msg);
                                                                                                             
  log_error($msg);
                                                                                                             
    log_error("backtrace:") if caller(0);
                                                                                                             
    my $pack = '';
    my $i = 0;
    while (1) {
        @DB::args = ();
                                                                                                             
        my @caller = caller($i);
                                                                                                             
        last unless @caller;
                                                                                                             
        my ($npack, $nfile, $nline, $subroutine, $hasargs,
            $wantarray, $evaltext, $is_require) = @caller;
                                                                                                             
        my $trace = '';
        $trace .= "  [$file:$line] ";
        $trace .= $wantarray ? "\@ " : "\$ ";
        $trace .= "$subroutine ";
        $trace .= "\"$evaltext\" " if defined($evaltext);
        $trace .= "(".join(", ",
                           map { (my $a = $_ || "") =~ s/\n/\\n/g; "\"$a\"";
                             } @DB::args).")"
            if $hasargs;
                                                                                                             
        log_error($trace);
                                                                                                             
        $i++;
                                                                                                             
        $file = $nfile;
        $line = $nline;
        $pack = $npack;
    }
    log_error("  [$file:$line]   ${pack}::");
}

__END__


=back

=head2 ~/.yample/dupdb

Yamples database of message IDs. Yample uses this to supress dupicate
messages (see dup() rules).

=head2 ~/.yample/log

Your own personal logfile. You might want to use logrotate or similar
programs to make sure it does not grow to big.

=head2 ~/.forward

Usually, your mail server looks for a file in your home directory called
".forward". This file contains information how your mail server should
deliver your mail. If you want Yample as your MDA your .forward should
look like this:
|/full/path/to/yample


=head1 EXAMPLES


# throw away virii
head(^X-Infected:):                    ignore()

# throw away spam with a score higher than 8
head(^X-Spam-Score: \d+\.\d+ \(\+{8,}\)

# The rest of the spam, tagged by spamassassin
head(^X-Spam-Flag: YES):               maildir(.junk.spam)

dup():                                 maildir(.junk.duplicates)

# auto-sort lists - requires Mail::Listdetect
list((.*)):                            maildir(.lists.$1) 

sender(@fjase.net) and subject(Backup report): maildir(.backup_reports)

# catch-all

perl(1):                               maildir()


=head1 VERSION

Yample 0.30

=head1 AUTHOR

Per Andreas Buer <perbu (at) linpro.no>

=head1 PREREQUSITES

Yamples needs the following perl modules. Please download from CPAN,
Yamples home page or other sources.

Mail::Internet
Mail::Send
Text::Balanced

Yample also uses these modules - but they are in the Perl
distribution so they should always be there. 

Pod::Usage
POSIX
Sys::Hostname
IO::File
IPC::Open2

=head1 BUGS

Yample with Spamassassin, Mail::ListDetector and the other bells and
whistles is quite heavy.

Please report bugs and functionality requests to the author.

Yample lacks (as of now) LMTP and IMAP support. Both should be fairly
easy to implement. 

=head1 COPYRIGHT

Copyright  2003 Per Andreas Buer

This is free software; see the source for copying conditions. There is
NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE.

=head1 SEE ALSO

Mail::Internet (3),  Mail::SpamAssassin (3), Mail::ListDetector (3).

=cut

