File Coverage

blib/lib/Email/LocalDelivery/Ezmlm.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch	5	10	50.0
condition			n/a
subroutine	4	4	100.0
pod	1	1	100.0
total	38	45	84.4

use strict;
package Email::LocalDelivery::Ezmlm;
our $VERSION = '0.10';
use File::Path qw(mkpath);
use File::Basename qw( dirname );

=head1 NAME

Email::LocalDelivery::Ezmlm - deliver mail into ezmlm archives

=head1 SYNOPSIS

 use Email::LocalDelivery;
 Email::LocalDelivery->deliver($mail, "/some/box//") or die "couldn't deliver";

=head1 DESCRIPTION

This module delivers RFC822 messages into ezmlm-style archive folders.

This module was created to allow easy interoperability between
L and L.  Colobus is an nntp server which uses ezmlm
archives as its message store.

=head1 METHODS

=head2 ->deliver( $message, @folders )

used as a class method.  returns the names of the files ultimately
delivered to

=cut

sub deliver {
    my ($class, $mail, @folders) = @_;

    my @delivered;
    for my $folder (@folders) {
        # trim the identifier off, as mkpath doesn't get on with it
        $folder =~ s{//?$}{};
        # XXX should lock the folder - figure out how ezmlm does that

        my $num;
        if (open my $fh, "$folder/num") {
            ($num) = (<$fh> =~ m/^(\d+)/);
        }
        ++$num;

        my $filename = sprintf('%s/archive/%d/%02d',
                               $folder, int $num / 100, $num % 100);
        eval { mkpath( dirname $filename ) };
        open my $fh, ">$filename" or next;
        print $fh $mail;
        close $fh or next;

        open $fh, ">$folder/num" or do { unlink $filename; next };
        print $fh "$num\n";
        close $fh or die "couldn't rewrite '$folder/num' $!";
        push @delivered, $filename;
    }
    return @delivered;
}

1;
__END__