#!/usr/bin/perl use strict; use warnings; use File::Basename; use Mail::Box::Manager; ### configuration ### my @our_domain = qw /mydomain.com mail.mydomain.com/; my $copymail = '/home/uksza/m/copymails'; ################### ### subs ### sub compress; #zip mail to zip-malibox sub change_name; #add date to name ############ my $mbm = Mail::Box::Manager->new; my $mbm_do = Mail::Box::Manager->new; my $mbox_cm = $mbm->open( folder => $copymail, access => 'rw' ) or die "Can't open $!"; my @all = $mbox_cm->messages; my $counter; foreach my $mail (@all) { #print for tests print $counter++ . "/$#all\n"; my @senders = $mail->from; my @recipients = $mail->destinations; #@senders = push @senders, @recipients; # - DOES'N WORK :-( save( $mail, @senders ); save( $mail, @recipients ); } #compress rest in start mbox $mbm->close($mbox_cm) or die "Can't close $mbox_cm"; compress( basename($copymail) ); ######################################### sub save { my $mail = shift; my @persons = @_; foreach my $person (@persons) { #users without hostname next if ( !$person->host ); #user not from our domains next unless ( grep { $person->host eq $_ } @our_domain ); my $name = lc $person->user; my $mails_to = $mbm_do->open( folder => "./$name", create => 1, access => 'a' ) or die "Can't work on mbox $name. $!"; $mbm->moveMessage( $mails_to, $mail ) or die "Moving problem $!"; $mbm_do->close($mails_to) or die "Close problem $!"; compress($name); } } #for archive on CD sub compress { my $box = shift; my $wyj = `gzip -c "$box" >> "$box.gz"`; change_name("$box.gz") if @{ [ stat("$box.gz") ] }[7] > 1024 * 1025*640 ; unlink $box or die "Unlink error. $!"; } #add _rrr-mm-dd to file name sub change_name { my $name = shift; my $year = @{ [localtime] }[5] + 1900; my $month = @{ [localtime] }[4] + 1; my $day = @{ [localtime] }[3]; my $data = sprintf "_%4d-%02d-%02d.gz", $year, $month, $day; my $new_name = $name. $data; rename $name, $new_name; }