Rev 38 | Rev 50 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
#! /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/>.
#
# for required libraries
# apt-get -y install libnet-imap-simple-ssl-perl libyaml-tiny-perl libhash-merge-simple-perl libclone-perl
use strict;
use warnings;
use Net::IMAP::Simple; # libnet-imap-simple-ssl-perl
use POSIX; # to get floor and ceil
use YAML::Tiny; # apt-get libyaml-tiny-perl under debian
use Clone 'clone'; # libclone-perl
use Hash::Merge::Simple qw/ merge clone_merge /; # libhash-merge-simple-perl
use Data::Dumper;
# globals
my $CONFIG_FILE_NAME = 'archiveIMAP.yaml';
# the default values for everything. These are overridden
# by default values in the conf file (.yaml) or by individual
# accounts entries.
my $config = {
'default' => {
# where the mail is going to
'target' => {
# these have no defaults. They should be in the configuration file
# 'password' => 'password',
# 'username' => 'username',
# hierarchy can be any combination of <path>, <month> and <year>
'hierarchy' => '<path>',
# default target server
'server' => 'localhost',
},
# where the mail is coming from
'source' => {
# these have no defaults. They should be in the configuration file
# 'password' => 'password',
# 'username' => 'username',
# Anything older than this is archived
# number of days unless followed by 'M' or 'Y', in which case it is
# multiplied by the number of days in a year (365.2425) or days in a month (30.5)
# may be a float, ie 1.25Y is the same as 15M
'age' => '1Y',
# if set to 1, any folders emptied out will be deleted EXCEPT system folders
'deleteEmptyFolders' => 0,
# default source server
'server' => 'localhost',
# these folders are considered system folders and never deleted, case insensitive
'system' => [
'Outbox',
'Sent Items',
'INBOX'
],
# these folders are ignored, ie not processed at all. Case insensitive
'ignore' => [
'Deleted Messages',
'Drafts',
'Junk E-mail',
'Junk',
'Trash'
],
# if 1, after successful copy to target, remove from source
'deleteOnSuccess' => 0
},
# if 1, does a dry run showing what would have happened
'testing' => 0,
# if 0, will not be processed
'enabled' => 1,
}
};
#
# 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();
if ( -e "$scriptLocation/$CONFIG_FILE_NAME" ) {
my $yaml = YAML::Tiny->read( "$scriptLocation/$CONFIG_FILE_NAME" );
# use clone_merge to merge conf file into $config
# overwrites anything in $config if it exists in the config file
$config = clone_merge( $config, $yaml->[0] );
return 1;
}
return 0;
}
# merges default into current account, overwriting anything not defined in account with
# value from default EXCEPT arrays labeled in @tags, which will be merged together.
sub fixupAccount {
my ( $default, $account ) = @_;
# these arrays, part of source, will be appended together instead of being overwritten
my @tags = ( 'ignore', 'system' );
# merge the tags in question. NOTE: they can only be in source
foreach my $tag ( @tags) {
if ( $default->{'source'}->{$tag} && $account->{'source'}->{$tag} ) {
my @j = ( @{$default->{'source'}->{$tag}}, @{$account->{'source'}->{$tag}} );
$account->{'source'}->{$tag} = \@j;
}
}
# now, merge account and default, with account taking precedence.
return clone_merge( $default, $account );
#my $c = clone_merge( $default, $account );
#return $c;
}
#
# 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
# $age is a float, possibly followed by a single character modifier
#
sub getDate {
my $age = shift;
# allow modifier to age which contains 'Y' (years) or 'M' (months)
# Simply set multiplier to the correct value, then multiply the value
$age = lc( $age );
if ( $age =~ m/([0-9.]+)([a-z])/ ) {
my $multiplier = ($2 == 'y' ? 365.2425 : ( $2 == 'm' ? 30.5 : MAXINT) );
$age = floor( $1 * $multiplier);
}
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 );
}
# main process loop to handle one account
#
sub processAccount {
my $account = shift;
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;
$messages = &processFolder( $sourceAccount, $targetAccount, $folder, $date, $$source{'separator'}, $$target{'separator'}, $deleteOnSuccess );
$TESTING ? print "Would expunge $folder\n" : $sourceAccount->expunge_mailbox( $folder );
# delete folder if empty and client has requested it.
( $TESTING ? print "Would delete $folder\n" : &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
&readConfig() || die "could not load config file\n";
#print Dumper( $config ); die;
foreach my $account ( keys %{$config->{'accounts'}} ) {
$config->{'accounts'}->{$account} = &fixupAccount( $config->{'default'}, $config->{'accounts'}->{$account} );
}
#print Dumper( $config ) ; die;
# just a place to gather some stats
my %processed;
$processed{'Accounts'} = 0;
$processed{'Messages'} = 0;
# grab only the accounts for simplicity
my $accounts = $config->{'accounts'};
# now, process each in turn
foreach my $account ( keys %$accounts ) {
# talk to user
print "Processing account $account\n";
# do the account. This is the main worker bee
$accounts->{$account}->{'processed'} = &processAccount( $accounts->{$account} );
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;