Subversion Repositories sysadmin_scripts

#! /usr/bin/perl -w

#    archiveIMAP: moves old messages from one IMAP account to another

#    maintaining hierarchy.

#    see http://wiki.linuxservertech.com for additional information

#    Copyright (C) 2014  R. W. Rodolico

#

#    version 1.0, 20140818

#       Initial Release

#

#    version 1.0.1 20140819

#        Removed dependancy on Email::Simple

#        Allowed 'separator' as an element in either source or target

#

#    This program is free software: you can redistribute it and/or modify

#    it under the terms of the GNU General Public License as published by

#    the Free Software Foundation, either version 3 of the License, or

#    (at your option) any later version.

#

#    This program is distributed in the hope that it will be useful,

#    but WITHOUT ANY WARRANTY; without even the implied warranty of

#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

#    GNU General Public License for more details.

#

#    You should have received a copy of the GNU General Public License

#    along with this program.  If not, see <http://www.gnu.org/licenses/>.

use strict;

use warnings;

use Net::IMAP::Simple; # libnet-imap-simple-ssl-perl

use POSIX; # to get floor and ceil

#use Data::Dumper;

# globals

my $CONFIG_FILE_NAME = 'archiveIMAP.cfg';

my $server = 'localhost'; # used if not specified in definition

# Following are added to ignore in definition in account (%accounts)

my @ignore = ( 'Deleted Messages','Drafts','Junk E-mail','Junk','Trash' );

# these are folders we may want to copy, but we never want to delete

my @systemFolders = ('Outbox','Sent Items','INBOX','Inbox');

my $deleteEmptyFolders = 1;

my $deleteOnSuccess = 1;

my %accounts;  # this must be configured in archiveIMAP.cfg. See sample.

#

# find where the script is actually located as cfg should be there

#

sub getScriptLocation {

   use strict;

   use File::Spec::Functions qw(rel2abs);

   use File::Basename;

   return dirname(rel2abs($0));

}

#

# Read the configuration file from current location 

# and return it as a string

#

sub readConfig {

   my $scriptLocation = &getScriptLocation();

   my $return = '';

   if ( -e "$scriptLocation/$CONFIG_FILE_NAME" ) {

      open CFG,"<$scriptLocation/$CONFIG_FILE_NAME" or die "Could not read $scriptLocation/$CONFIG_FILE_NAME: $!\n";

      $return = join ( '', <CFG> );

      close CFG;

   }

   return $return;

}

#

# Open an IMAP connection

#

sub openIMAPConnection {

   my ( $server, $username, $password ) = @_;

   my $imap = Net::IMAP::Simple->new( $server ) ||

    die "Unable to connect to IMAP: $Net::IMAP::Simple::errstr\n";

   # Log on

   if(!$imap->login( $username, $password )){

     die "Login failed: " . $imap->errstr . "\n";

   }

   return $imap;

}

#

# returns a string in proper format for RFC which is $age days ago

#

sub getDate {

   my $age = shift;

   my @months = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

   my @now = localtime(time - 24 * 60 * 60 * $age);

   $now[4] = @months[$now[4]];

   $now[5] += 1900;

   my $date = sprintf( "%d-%s-%d", $now[3],$now[4],$now[5] ) ; # '1-Jan-2014';

   return $date;

}

#

# Get a list of all folders to be processed

# currently, it just weeds out items in the ignore list

#

sub getFolders {

   my ($imap, $ignore, $separator) = @_;

   $separator = '\\' . $separator;

   # build a regex that will be used to filter the input

   # assuming Trash, Drafts and Junk are in the ignore list

   # and a period is the separator, the generated regex is

   # (^|(\.))((Trash)|(Drafts)|(Junk))((\.)|$)

   # which basically says ignore those folders, but not substrings of them

   # ie, Junk02 would not be filtered but Junk would

   my $ignoreRegex = "(^|($separator))((" . join( ")\|(", @$ignore ) . "))(($separator)|\$)";

   # read all mailboxes and filter them with above regex into @boxes

   my @boxes = grep{ ! /$ignoreRegex/ } $imap->mailboxes;

   return \@boxes;

}

#

# make a folder on the IMAP account. The folder is assumed to be the

# fully qualified path with the correct delimiters

#

sub makeFolder {

   my ($imap, $folder, $delimiter) = @_;

   print "\n\t\tCreating folder $folder";

   # you must create the parent folder before creating the children

   my $escapedDelimiter = '\\' . $delimiter;

   my @folders = split( $escapedDelimiter, $folder );

   $folder = '';

   # take them from the left and, if they don't exist, create it

   while ( my $subdir = shift @folders ) {

      $folder .= $delimiter if $folder;

      $folder .= $subdir;

      next if $imap->select( $folder ); # already created, so look deeper in hierachy

      print "\n\t\t\tCreating subfolder $folder";

      $imap->create_mailbox( $folder ) || warn $imap->errstr();

      $imap->folder_subscribe( $folder ) || die $imap->errstr();

      unless ( $imap->select( $folder ) ) { # verify it was created

         warn "Unable to create $folder on target account\n";

         return 0;

      } # unless

   } # while

   return $folder;

}

#

# Delete an IMAP folder

#

sub deleteAFolder {

   my ($sourceAccount, $folder, $separator, $systemFolders) = @_;

   return 1 if $folder eq 'INBOX'; # do NOT mess with INBOX

   return 2 if $sourceAccount->select($folder) > 0; # do not mess with it if it still has messages in it

   return 3 if $sourceAccount->mailboxes( $folder . $separator . '*' ); # do not mess with it if it has subfolders

   return 4 if ( ref ( $systemFolders ) eq 'ARRAY' ) && ( grep{$_ eq $folder} @$systemFolders );

   print "\n\t\tDeleting empty folder $folder";

   $sourceAccount->folder_unsubscribe($folder);

   $sourceAccount->delete_mailbox( $folder );

}

#

# If folder has messages that match the criteria, move them to target

# creates the target folder if necessary

#

sub processFolder {

   my ( $sourceAccount, $targetAccount, $folder, $dateBefore, $sourceDelimiter, $targetDelimiter, $deleteOnSuccess ) = @_;

   my $numMessages = 0;

   $sourceAccount->expunge_mailbox( $folder ); # clean it up so we don't copy deleted messages

   $sourceAccount->select( $folder ) or die "Could not connect to folder $folder\n"; # move into the correct folder for the source

   my @ids = $sourceAccount->search_sent_before( $dateBefore ); # use sent_before to get the sent date from message

#   print join( "\n\t\t\t", @ids ) . "\n";

   return 0 unless @ids; # we have nothing to copy, so exit

   if ( $sourceDelimiter ne $targetDelimiter ) { # different delimiters, so we have to change them in the folder def

      # they may contain meta chars, so escape them. We can use \Q \E in the pattern to match, but the 

      # second part of the s/// will substitute literal EXCEPT for the delimiter and the dollar sign

      # I'm escaping the double quote (what I'm using for the delimiter) "just in case" but I'm not doing

      # the dollar sign, so this will fail, fail, fail if there is an issue there.

      my $escapedTargetDelimiter = $targetDelimiter eq '"' ? '\\' .  $targetDelimiter : $targetDelimiter;

      $folder =~ s"\Q$sourceDelimiter\E"$escapedTargetDelimiter"g;

   }

   if ( $targetAccount->select( $folder ) || &makeFolder( $targetAccount, $folder, $targetDelimiter ) ) {

      foreach my $id ( @ids ) {

         my @flags = $sourceAccount->msg_flags( $id );

         my $message = $sourceAccount->get( $id ) or die $sourceAccount->errstr;

         if ( $targetAccount->put( $folder, $message, @flags ) ) {

            $sourceAccount->delete( $id ) if ( $deleteOnSuccess ) ;

            $numMessages++;

         } else {

            die "Could not write to target, aborting\n$targetAccount->errstr\n";

         }

      }

   } else {

      warn "\t\t$folder not found in target and could not create it\n";

   }

   return $numMessages;

}

#

# main processing loop to handle one account

#

sub processAccount {

   my ( $source, $target, $age, $ignore, $deleteOnSuccess, $deleteEmptyFolders ) = @_;

   my $date = getDate( $age );

   print "\t" . ( $deleteOnSuccess ? 'Moving' : 'Copying' ) . " all messages before $date\n";

   # open and log into both source and target, and get the separator used

   my $sourceAccount = &openIMAPConnection( $$source{'server'}, $$source{'username'}, $$source{'password'} );

   my $targetAccount = &openIMAPConnection( $$target{'server'}, $$target{'username'}, $$target{'password'} );

   $$source{'separator'} = $sourceAccount->separator unless $$source{'separator'};

   $$target{'separator'} = $targetAccount->separator unless $$target{'separator'};

   # get a list of all folders to be processed on the source

   $$source{'folders'} = &getFolders( $sourceAccount, $ignore, $$source{'separator'} );

   #print Dumper( $targetAccount );

   #die;

   my $folderList = $$source{'folders'};

   my $count = 0; # count the number of messages processed

   my $processedCount = 0; # count the number of folders processed

   foreach my $folder ( @$folderList ) {

      print "\t$folder";

      my $messages = &processFolder( $sourceAccount, $targetAccount, $folder, $date, $$source{'separator'}, $$target{'separator'}, $deleteOnSuccess );

      $sourceAccount->expunge_mailbox( $folder );

      # delete folder if empty and client has requested it.

      &deleteAFolder( $sourceAccount, $folder, $$source{'separator'}, $$source{'systemfolder'} ) if ( $deleteEmptyFolders );

      print "\n\t\t$messages processed\n";

      $count += $messages;

      $processedCount++;

      # next line used only for testing. Dies after 5 folders on first account

      # last if $processedCount > 5;

   }

   $sourceAccount->quit;

   $targetAccount->quit;

   return $count;

}

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

#                   Main                                              #

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

# read and evaluate configuration file

if ( my $config = readConfig() ) {

   eval $config; 

   die "Error in configuraration file $CONFIG_FILE_NAME\n$@" if $@;

} else {

   die "Configurastion file $CONFIG_FILE_NAME must be located in script directory\n";

}

my %processed;

$processed{'Accounts'} = 0;

$processed{'Messages'} = 0;

foreach my $account ( keys %accounts ) {

   # talk to user

   print "Processing account $account\n";

   # Set some defaults from globals if they were not defined

   $accounts{$account}{'source'}{'server'} = $server unless exists( $accounts{$account}{'source'}{'server'} );

   $accounts{$account}{'target'}{'server'} = $server unless exists( $accounts{$account}{'target'}{'server'} );

   $accounts{$account}{'deleteOnSuccess'} = $deleteOnSuccess unless exists $accounts{$account}{'deleteOnSuccess'};

   $accounts{$account}{'deleteEmptyFolders'} = $deleteEmptyFolders unless exists $accounts{$account}{'deleteEmptyFolders'};

   if ( exists $accounts{$account}{'ignore'} ) {

      foreach my $element ( @ignore ) {

         push $accounts{$account}{'ignore'}, $element;

      }

   } else {

      $accounts{$account}{'ignore'} = \@ignore;

   }

   if ( exists $accounts{$account}{'source'}{'systemFolders'} ) {

      foreach my $element ( @systemFolders ) {

         push $accounts{$account}{'source'}{'systemFolders'}, $element;

      }

   } else {

      $accounts{$account}{'source'}{'systemFolders'} = \@systemFolders;

   }

   # do the account

   $accounts{$account}{'processed'} =

            &processAccount( 

                     $accounts{$account}{'source'},

                     $accounts{$account}{'target'},

                     $accounts{$account}{'age'},   

                     $accounts{$account}{'ignore'},

                     $accounts{$account}{'deleteOnSuccess'},

                     $accounts{$account}{'deleteEmptyFolders'}

                     );

   print "Done, $accounts{$account}{'processed'} messages copied\n";

   $processed{'Accounts'}++;

   $processed{'Messages'} += $accounts{$account}{'processed'};

} # foreach loop

print "$processed{'Accounts'} accounts processed, $processed{'Messages'} messages\n";

1;