imap_filter.pl -- Mail Filtering via IMAP with Perl

Thunderbird is a big thing. It is an even bigger thing when you have several mailboxes. So, while I've not yet given up on Thunderbird, I have taken to not have it running unless I know I need it. That is where jBiff, my IMAP-to-XMPP thingee, comes in. I've even taken to using the web interfaces instead of Thunderbird on occasion. All is well in the world.

But there's a problem.

Lists. Lists and filters. Filtering lists. ( That makes it one problem again. )

I'm used to using slocal or procmail on Unix machines to filter as the mail comes in. I'm not nearly as happy with the interface to filtering in Gmail, but I do love the result, which is a cleaner inbox.

My work mail has filtering that's enabled when you use the web interface. I don't use the web interface often, and when I have all my filters in Thunderbird, nothing is filtered when I use the web. What I needed is a means to write my filters outside of a mail client and have them run regularly, so that the state of the inbox is always as it should be.

So, I wrote imap_filter.pl. It needs to be cleaned up a bit, and it is not feature-complete, but I'm able to move mail based on many good things, so I'm at a done point.

#!/usr/bin/perl
use 5.010 ;
use strict ;
use warnings ;
use lib '/home/jacoby/bin' ;
use Carp ;
use Data::Dumper ;
use Getopt::Long ;
use IO::Socket::SSL ;
use IO::Interactive qw{interactive} ;
use Mail::IMAPClient ;
use IdentConf ':all' ;
use subs qw{ imap_part xmpp_part } ;

$Data::Dumper::Indent = 1 ;
my $debug ;
my $imap_identity ;

#methods
my @from ;
my @to ;
my @cc ;
my @subject ;
my @to_or_cc ; # don't use or yet.
my $age = 0 ;

#actions
my $move ; #move to dir
my $forward ; #forward to this address
my $delete ; #delete this file
my $read ;
my $unread ;

GetOptions(
            'imap=s'    => \$imap_identity,
            'from=s'    => \@from,
            'to=s'      => \@to,
            'cc=s'      => \@cc,
            'or=s'      => \@to_or_cc,
            'subject=s' => \@subject,
            'age=i'     => \$age,

            'move=s'    => \$move ,
            'delete'    => \$delete ,
            'read'      => \$read ,
            ) or exit( 1 ) ;

exit if !defined $imap_identity ;
exit if length $imap_identity < 1 ;

for my $a ( @to_or_cc ) {
    push @to, $a ;
    push @cc, $a ;
    }

my $filter ;
$filter->{ from }    = \@from ;
$filter->{ subject } = \@subject ;
$filter->{ to }      = \@to ;
$filter->{ cc }      = \@cc ;
$filter->{ age }     = $age ;

$filter->{ move }    = $move ;
$filter->{ read }    = $read ;
$filter->{ delete }  = $delete ;

imap_part $filter ;
exit ;

# ====================================================================
#
# connect to and search your mail server via IMAP
#
# ====================================================================
sub imap_part {
    my ( $filter ) = @_ ;
    say { interactive } Dumper $filter ;

    my %creds = get_credentials( 'imap', $imap_identity ) ;

    my $socket = IO::Socket::SSL->new( PeerAddr => $creds{ server },
                                       PeerPort => $creds{ port },
                                       ) or die "socket(): $@" ;

    my $client = Mail::IMAPClient->new( Socket   => $socket,
                                        User     => $creds{ username },
                                        Password => $creds{ password },
                                        ) or die "new(): $@" ;

    if ( $client->IsAuthenticated() ) {
        $client->select( $creds{ directory } )
          or die "Select '$creds{directory}' error: ",
          $client->LastError, "\n" ;

        my $i = 1 ;
        for my $msg ( reverse $client->messages ) {
            my $flag    = 0 ;
            my $from    = $client->get_header( $msg, 'From' ) ;
            my $sender  = $client->get_header( $msg, 'Sender' ) ;
            my $date    = $client->date( $msg ) ;
            my $to      = $client->get_header( $msg, 'To' ) ;
            my $cc      = $client->get_header( $msg, 'Cc' ) ;
            my $subject = $client->subject( $msg ) ;
            my @flags   = $client->flags( $msg ) ;
            my $seen = 0 ; $seen = 1 if grep m{/Seen}mx , @flags ;
            next if grep m{\Deleted}mx , @flags ;

            # Subject
            if ( scalar @{ $filter->{ subject } } > 0 ) {
                for my $f ( $filter->{ subject } ) {
                    my $ff = $$f[ 0 ] ;
                    $subject =~ m{($ff)}mix ;
                    say $1 if defined $1 ;
                    $flag++ unless defined $1 ;
                    }
                }
            # From
            if ( scalar @{ $filter->{ from } } > 0 ) {
                for my $f ( $filter->{ from } ) {
                    my $ff = $$f[ 0 ] ;
                    $from =~ m{($ff)}mix ;
                    $flag++ unless defined $1 ;
                    }
                }
            # To
            if ( scalar @{ $filter->{ to } } > 0 && ! defined $to ) {
                $flag++ ;
                }
            if ( scalar @{ $filter->{ to } } > 0 && defined $to ) {
                for my $f ( $filter->{ to } ) {
                    my $ff = $$f[ 0 ] ;
                    $to =~ m{($ff)}mix ;
                    $flag++ unless defined $1 ;
                    }
                }
            # Cc
            if ( scalar @{ $filter->{ cc } } > 0 && ! defined $cc ) {
                $flag++ ;
                }
            if ( scalar @{ $filter->{ cc } } > 0 && defined $cc ) {
                for my $f ( $filter->{ cc } ) {
                    my $ff = $$f[ 0 ] ;
                    $cc =~ m{($ff)}mix ;
                    $flag++ unless defined $1 ;
                    }
                }
            # Age
                #GOT NADA

            next if $flag ;

            if ( 1 ) {
                my $title = 'New mail from ' . $from ;
                my $body  = $subject ;
                $body = join q{"}, '', $body, '' ;

                #say { interactive } "$title - $body" ;
                say { interactive } $i++ . "\t" . '=' x 40 ;
                say { interactive } $subject;
                say { interactive }   'From:     ' . $from ;
                say { interactive }   '  Sender: ' . $sender if $sender  ;
                say { interactive }   '      To: ' . $to if $to ;
                say { interactive }   '      Cc: ' . $cc if $cc ;
                say { interactive }   '    Date: ' . $date ;
                say { interactive }   join ' ' , ' ' , @flags ;
                if ( $filter->{ move } ) {
                    my $move = $filter->{ move } ;
                    say { interactive } '    Move: ' . $move ;
                    my $newUid = $client->move( $move , $msg )
                        or die "Could not move: $@\n";
                    }
                say { interactive } '' ;
                }
            }
        $client->logout() ;
        }
    else {
        say { interactive } 'FAIL ' . $! ;
        }
    }

# --------------------------------------------------------------------