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.

view plainprint?

1. #!/usr/bin/perl  
2. use 5.010 ;  
3. use strict ;  
4. use warnings ;  
5. use lib '/home/jacoby/bin' ;  
6. use Carp ;  
7. use Data::Dumper ;  
8. use Getopt::Long ;  
9. use IO::Socket::SSL ;  
10. use IO::Interactive qw{interactive} ;  
11. use Mail::IMAPClient ;  
12. use IdentConf ':all' ;  
13. use subs qw{ imap_part xmpp_part } ;  
14.   
15. $Data::Dumper::Indent = 1 ;  
16. my $debug ;  
17. my $imap_identity ;  
18.   
19. #methods  
20. my @from ;  
21. my @to ;  
22. my @cc ;  
23. my @subject ;  
24. my @to_or_cc ; # don't use or yet.  
25. my $age = 0 ;  
26.   
27. #actions  
28. my $move ; #move to dir  
29. my $forward ; #forward to this address  
30. my $delete ; #delete this file  
31. my $read ;  
32. my $unread ;  
33.   
34. GetOptions(  
35.             'imap=s'    => \$imap_identity,  
36.             'from=s'    => \@from,  
37.             'to=s'      => \@to,  
38.             'cc=s'      => \@cc,  
39.             'or=s'      => \@to_or_cc,  
40.             'subject=s' => \@subject,  
41.             'age=i'     => \$age,  
42.   
43.             'move=s'    => \$move ,  
44.             'delete'    => \$delete ,  
45.             'read'      => \$read ,  
46.             ) or exit( 1 ) ;  
47.   
48. exit if !defined $imap_identity ;  
49. exit if length $imap_identity < 1 ;  
50.   
51. for my $a ( @to_or_cc ) {  
52.     push @to, $a ;  
53.     push @cc, $a ;  
54.     }  
55.   
56. my $filter ;  
57. $filter->{ from }    = \@from ;  
58. $filter->{ subject } = \@subject ;  
59. $filter->{ to }      = \@to ;  
60. $filter->{ cc }      = \@cc ;  
61. $filter->{ age }     = $age ;  
62.   
63. $filter->{ move }    = $move ;  
64. $filter->{ read }    = $read ;  
65. $filter->{ delete }  = $delete ;  
66.   
67. imap_part $filter ;  
68. exit ;  
69.   
70. # ====================================================================  
71. #  
72. # connect to and search your mail server via IMAP  
73. #  
74. # ====================================================================  
75. sub imap_part {  
76.     my ( $filter ) = @_ ;  
77.     say { interactive } Dumper $filter ;  
78.   
79.     my %creds = get_credentials( 'imap', $imap_identity ) ;  
80.   
81.     my $socket = IO::Socket::SSL->new( PeerAddr => $creds{ server },  
82.                                        PeerPort => $creds{ port },  
83.                                        ) or die "socket(): $@" ;  
84.   
85.     my $client = Mail::IMAPClient->new( Socket   => $socket,  
86.                                         User     => $creds{ username },  
87.                                         Password => $creds{ password },  
88.                                         ) or die "new(): $@" ;  
89.   
90.     if ( $client->IsAuthenticated() ) {  
91.         $client->select( $creds{ directory } )  
92.           or die "Select '$creds{directory}' error: ",  
93.           $client->LastError, "\n" ;  
94.   
95.         my $i = 1 ;  
96.         for my $msg ( reverse $client->messages ) {  
97.             my $flag    = 0 ;  
98.             my $from    = $client->get_header( $msg, 'From' ) ;  
99.             my $sender  = $client->get_header( $msg, 'Sender' ) ;  
100.             my $date    = $client->date( $msg ) ;  
101.             my $to      = $client->get_header( $msg, 'To' ) ;  
102.             my $cc      = $client->get_header( $msg, 'Cc' ) ;  
103.             my $subject = $client->subject( $msg ) ;  
104.             my @flags   = $client->flags( $msg ) ;  
105.             my $seen = 0 ; $seen = 1 if grep m{/Seen}mx , @flags ;  
106.             next if grep m{\Deleted}mx , @flags ;  
107.   
108.             # Subject  
109.             if ( scalar @{ $filter->{ subject } } > 0 ) {  
110.                 for my $f ( $filter->{ subject } ) {  
111.                     my $ff = $$f[ 0 ] ;  
112.                     $subject =~ m{($ff)}mix ;  
113.                     say $1 if defined $1 ;  
114.                     $flag++ unless defined $1 ;  
115.                     }  
116.                 }  
117.             # From  
118.             if ( scalar @{ $filter->{ from } } > 0 ) {  
119.                 for my $f ( $filter->{ from } ) {  
120.                     my $ff = $$f[ 0 ] ;  
121.                     $from =~ m{($ff)}mix ;  
122.                     $flag++ unless defined $1 ;  
123.                     }  
124.                 }  
125.             # To  
126.             if ( scalar @{ $filter->{ to } } > 0 && ! defined $to ) {  
127.                 $flag++ ;  
128.                 }  
129.             if ( scalar @{ $filter->{ to } } > 0 && defined $to ) {  
130.                 for my $f ( $filter->{ to } ) {  
131.                     my $ff = $$f[ 0 ] ;  
132.                     $to =~ m{($ff)}mix ;  
133.                     $flag++ unless defined $1 ;  
134.                     }  
135.                 }  
136.             # Cc  
137.             if ( scalar @{ $filter->{ cc } } > 0 && ! defined $cc ) {  
138.                 $flag++ ;  
139.                 }  
140.             if ( scalar @{ $filter->{ cc } } > 0 && defined $cc ) {  
141.                 for my $f ( $filter->{ cc } ) {  
142.                     my $ff = $$f[ 0 ] ;  
143.                     $cc =~ m{($ff)}mix ;  
144.                     $flag++ unless defined $1 ;  
145.                     }  
146.                 }  
147.             # Age  
148.                 #GOT NADA  
149.   
150.             next if $flag ;  
151.   
152.             if ( 1 ) {  
153.                 my $title = 'New mail from ' . $from ;  
154.                 my $body  = $subject ;  
155.                 $body = join q{"}, '', $body, '' ;  
156.   
157.                 #say { interactive } "$title - $body" ;  
158.                 say { interactive } $i++ . "\t" . '=' x 40 ;  
159.                 say { interactive } $subject;  
160.                 say { interactive }   'From:     ' . $from ;  
161.                 say { interactive }   '  Sender: ' . $sender if $sender  ;  
162.                 say { interactive }   '      To: ' . $to if $to ;  
163.                 say { interactive }   '      Cc: ' . $cc if $cc ;  
164.                 say { interactive }   '    Date: ' . $date ;  
165.                 say { interactive }   join ' ' , ' ' , @flags ;  
166.                 if ( $filter->{ move } ) {  
167.                     my $move = $filter->{ move } ;  
168.                     say { interactive } '    Move: ' . $move ;  
169.                     my $newUid = $client->move( $move , $msg )  
170.                         or die "Could not move: $@\n";  
171.                     }  
172.                 say { interactive } '' ;  
173.                 }  
174.             }  
175.         $client->logout() ;  
176.         }  
177.     else {  
178.         say { interactive } 'FAIL ' . $! ;  
179.         }  
180.     }  
181.   
182. # --------------------------------------------------------------------  

#!/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 ' . $! ;
        }
    }

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