WebSVN – sysadmin_scripts – Diff – /trunk/archiveIMAP/archiveIMAP

+#
 #    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
+#    apt-get -y install libnet-imap-simple-ssl-perl libyaml-tiny-perl libhash-merge-simple-perl libclone-perl libdate-manip-perl libemail-simple-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 Date::Manip; # libdate-manip-perl
+use Email::Simple; # libemail-simple-perl
+use Date::Parse;
 use Data::Dumper;
 # globals
 my $CONFIG_FILE_NAME = 'archiveIMAP.yaml';
                                  '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
+#
    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])/ ) {
+      # ~0 is the maximum integer which can be stored. Shifting right one gives max unsigned integer
-      my $multiplier = ($2 == 'y' ? 365.2425 : ( $2 == 'm' ? 30.5 : MAXINT) );
+      my $multiplier = ($2 eq 'y' ? 365.2425 : ( $2 eq 'm' ? 30.5 : ~0 >> 1) );
       $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;
+}
+# calculateTargetFolder
+# we are passed the target and the message
+# pattern is carot (^) separated and may contain
+# special placeholders <path>, <year>, <month>
+# anything else is inserted directly
+sub calculateTargetFolder {
+   my ( $message, $source, $target ) = @_;
+   # we may be sorting by date
+   my $email = Email::Simple->new( join( '', @$message ) );
+   my $msgDate = $email->header('Date');
+   my @t = strptime( $msgDate );
+   my $month = $t[4]+1;
+   $month = '0' . $month if $month < 10;
+   my $year = $t[5]+1900;
+   # now, build the path on the new machine
+   my $sourceFolder = join ( $target->{'separator'}, @{ $source->{'source folder list'} } );
+   my $targetPattern = join( $target->{'separator'}, @{ $target->{'hierachy pattern'} } );
+   $targetPattern =~ s/<path>/$sourceFolder/gi;
+   $targetPattern =~ s/<month>/$month/gi;
+   $targetPattern =~ s/<year>/$year/gi;
+   # return the string we created, separated by
+   # the delimiters for the target
+   return $targetPattern;
+}
+# If folder has messages that match the criteria, move them to target
+# creates the target folder if necessary
+#
+sub processFolder {
+   my ( $source, $target, $folder, $TESTING ) = @_;
+   #$dateBefore, $sourceDelimiter, $targetDelimiter, $deleteOnSuccess
+   print "\n=== Processing $folder\n";
+   my $sourceAccount = $source->{'connection'};
+   my $targetAccount = $target->{'connection'};
+   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( $source->{'before date'} ); # 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
+   # make life easier by precalculating some paths as array pointers
+   my @sourceFolders = split( '\\' . $source->{'separator'}, $folder );
+   my @pattern = split '\\^', $target->{'hierarchy'};
+   $source->{'source folder list'} = \@sourceFolders;
+   $target->{'hierachy pattern'} = \@pattern;
+#   print "\n\nDumping information\n";
+#   print "Source Folder $folder\n";
+#   print "Source Separator $source->{'separator'}\n";
+#   print Dumper( $source->{'source folder list'} ) . "\n";
+#   print "Target Separator $target->{'separator'}\n";
+#   print "Target Hierarchy $target->{'hierarchy'}\n";
+#   print Dumper( $target->{'hierachy pattern'} ) . "\n";
+#   print 'Source => ' . join( "\n", @sourceFolders ) . "\n";
+#   print 'Pattern => ' . join( "\n", @pattern ) . "\n";
+   # process each message to be done
+   foreach my $id ( @ids ) {
+      # get the flags
+      my @flags = $sourceAccount->msg_flags( $id );
+      # get the message
+      my $message = $sourceAccount->get( $id ) or die $sourceAccount->errstr;
+      # calculate where we are going to move this to
+      my $targetFolder = &calculateTargetFolder( $message, $source, $target );
+      if ( $TESTING ) {
+         print "Would have moved message to $targetFolder\n";
+         next;
+      }
+      if ( $target->{'connection'}->select( $folder ) || &makeFolder( $target->{'connection'}, $folder, $target->{'separator'} ) ) {
+         if ( $target->{'connection'}->put( $folder, $message, @flags ) ) {
+            $source->{'connection'}->delete( $id ) if ( $source->{'deleteOnSuccess'} ) ;
+            $numMessages++;
+         } else {
+            die "Could not write to target, aborting\n$target->{'connection'}->errstr\n";
+         }
+      } else {
+         warn "\t\t$folder not found in target and could not create it\n";
+      }
+   }
+   return $numMessages;
+}
+#
 # Get a list of all folders to be processed
 # currently, it just weeds out items in the ignore list
+#
 sub getFolders {
    # (^|(\.))((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;
+   my @boxes = grep{ ! /$ignoreRegex/i } $imap->mailboxes;
    return \@boxes;
+}
+#
 # make a folder on the IMAP account. The folder is assumed to be the
+#
 # Delete an IMAP folder
+#
 sub deleteAFolder {
-   my ($sourceAccount, $folder, $separator, $systemFolders) = @_;
+   my ($source, $folder, $TESTING ) = @_;
+   my $sourceAccount = $source->{'connection'};
+   my $separator = $source->{'separator'};
    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 );
+   return 4 if $source->{'system folders'}->{lc $folder}; # do not mess with system folders
-   print "\n\t\tDeleting empty folder $folder";
+   print "\n\t\tDeleting empty folder $folder" . ( $TESTING ? ' Dry Run' : '' );
+   return if $TESTING;
    $sourceAccount->folder_unsubscribe($folder);
    $sourceAccount->delete_mailbox( $folder );
+}
 # main process loop to handle one account
+#
 sub processAccount {
    my $account = shift;
-   my $date = &getDate( $age );
+   next unless $account->{'enabled'}; # blow it off if it is not enabled
-   print "\t" . ( $deleteOnSuccess ? 'Moving' : 'Copying' ) . " all messages before $date\n";
+   my $TESTING = $account->{'testing'}; # create mini global if we should test this account
    # open and log into both source and target, and get the separator used
+   foreach my $acct ( 'target','source' ) {
-   my $sourceAccount = &openIMAPConnection( $$source{'server'}, $$source{'username'}, $$source{'password'} );
+      $account->{$acct}->{'connection'} = &openIMAPConnection( $account->{$acct}->{'server'}, $account->{$acct}->{'username'}, $account->{$acct}->{'password'} );
+      unless ( $account->{$acct}->{'connection'} ) {
-   my $targetAccount = &openIMAPConnection( $$target{'server'}, $$target{'username'}, $$target{'password'} );
+         warn "Unable to open $acct for $account->{$acct}->{username}, aborting move: $!\n";
+         return -1;
+      }
-   $$source{'separator'} = $sourceAccount->separator unless $$source{'separator'};
+      $account->{$acct}->{'separator'} = $account->{$acct}->{'connection'}->separator unless $account->{$acct}->{'separator'};
+   }
+   # just being set up for convenience and readability
+   my $source = $account->{'source'};
+   my $target = $account->{'target'};
+   my %temp = map{ lc($_) => 1 } @{$source->{'system'}};
+   $source->{'system folders'} = \%temp;
-   $$target{'separator'} = $targetAccount->separator unless $$target{'separator'};
+   $source->{'before date'} = &getDate( $account->{'age'} );
+   print "\t" . ( $source->{'deleteOnSuccess'} ? 'Moving' : 'Copying' ) . " all messages before $source->{'before date'}\n";
    # get a list of all folders to be processed on the source
-   $$source{'folders'} = &getFolders( $sourceAccount, $ignore, $$source{'separator'} );
+   $source->{'folders'} = &getFolders( $source->{'connection'}, $source->{'ignore'}, $source->{'separator'} );
-   #print Dumper( $targetAccount );
-   #die;
-   my $folderList = $$source{'folders'};
+   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 );
+      $messages = &processFolder( $source, $target, $folder, $TESTING ); #, $date, $$source{'separator'}, $$target{'separator'}, $deleteOnSuccess );
-      $TESTING ? print "Would expunge $folder\n" : $sourceAccount->expunge_mailbox( $folder );
+      $TESTING ? print "Would expunge $folder\n" : $source->{'connection'}->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 );
+      ( $TESTING ? print "Would delete $folder\n" : &deleteAFolder( $source, $folder, $TESTING ) ) if $account->{'source'}->{'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;
+      last if $processedCount > 5;
+   }
-   $sourceAccount->quit;
+   $source->{'connection'}->quit;
-   $targetAccount->quit;
+   $target->{'connection'}->quit;
    return $count;
+}
 $processed{'Accounts'} = 0;
 $processed{'Messages'} = 0;
 # grab only the accounts for simplicity
 my $accounts = $config->{'accounts'};
+print Dumper( $config ) ; die;
 # 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'};
+   # free up space we allocated since we stored a bunch of stuff in there, and we don't need it anymore
+   $accounts->{$account} = undef;
 } # foreach loop
 print "$processed{'Accounts'} accounts processed, $processed{'Messages'} messages\n";

Subversion Repositories sysadmin_scripts

(root)/trunk/archiveIMAP/archiveIMAP – Rev 40 → 42