File Coverage

blib/lib/Email/Delete/Mbox.pm

Criterion	Covered	Total	%
statement	44	44	100.0
branch	3	4	75.0
condition			n/a
subroutine	11	11	100.0
pod	0	1	0.0
total	58	60	96.6

package Email::Delete::Mbox;
# $Id: Mbox.pm,v 1.3 2004/12/17 18:45:50 cwest Exp $
use strict;

{
    package Email::LocalDelivery::OverwriteMbox;
    use base qw[Email::LocalDelivery::Mbox];
    my $fh;
    sub _set_fh { $fh = $_[1] }
    sub _open_fh { $fh }
    sub _close_fh { 1 }
}

package Email::Delete::Mbox;
use base qw[Email::Folder::Mbox];

use vars qw[$VERSION];
$VERSION = '2.002';

use Email::Folder;
use IO::File;

sub delete_message {
    my %args = @_;

    my $fh     = IO::File->new($args{from}, '+<');
    flock $fh, 2;
    {
        local $^W = 0;
        *_get_fh = sub { $fh };
    }
    my $folder = Email::Folder->new(
                                    $args{from},
                                    reader => __PACKAGE__,
                                   );

    my (@keep, @delete);
    while ( my $message = $folder->next_message ) {
        my $trash_it = $args{matching}->($message);
        if ( $trash_it ) {
            push @delete, $message;
            next;
        }
        push @keep, $message;
    }

    return 0 unless @delete;

    seek $fh, 0, 0;
    Email::LocalDelivery::OverwriteMbox->_set_fh($fh);
    Email::LocalDelivery::OverwriteMbox->deliver($_->as_string, $fh)
        for @keep;
    Email::LocalDelivery::OverwriteMbox->_set_fh(undef);
    truncate $fh, tell $fh;
    close $fh;

    return scalar @delete;
}

1;

__END__