File Coverage

blib/lib/Mail/POP3/Folder/mbox.pm

Criterion	Covered	Total	%
statement	133	178	74.7
branch	23	42	54.7
condition	6	9	66.6
subroutine	22	30	73.3
pod	14	14	100.0
total	198	273	72.5

package Mail::POP3::Folder::mbox;

our @ISA = qw(Mail::POP3::Folder);

use strict;
use IO::File;
use Fcntl ':flock';

my $CRLF = "\015\012";

sub new {
    my (
        $class,
        $user_name,
        $password,
        $user_id,
        $mailgroup,
        $spoolfile,
        $message_start,
        $message_end,
    ) = @_;
    my $self = {};
    bless $self, $class;
    $self->{CLIENT_USER_ID} = $user_id;
    $self->{MAILGROUP} = $mailgroup;
    $self->{SPOOLFILE} = $spoolfile;
    $self->{MESSAGE_START} = $message_start;
    $self->{MESSAGE_END} = $message_end;
    $self->{MESSAGECNT} = 0;
    $self->{MSG2OCTETS} = {};
    $self->{MSG2UIDL} = {};
    $self->{MSG2FROMLINE} = {};
    $self->{MSG2TEXT} = {};
    $self->{TOTALOCTETS} = 0;
    $self->{DELMESSAGECNT} = 0;
    $self->{DELTOTALOCTETS} = 0;
    $self;
}

sub _start_new_message {
    my ($self, $newmessageno, $fromline) = @_;
    # Hold the "From ..." line to put back if message is not retrieved
    $self->{MSG2FROMLINE}->{$newmessageno} = $fromline;
}

sub _close_old_message {
    my ($self, $oldmessageno, $messageuidl, $messageoctets) = @_;
    return if $oldmessageno <= 0;
    $self->{TOTALOCTETS} += $messageoctets;
    $self->{MSG2OCTETS}->{$oldmessageno} = $messageoctets;
    $self->{MSG2UIDL}->{$oldmessageno} = $messageuidl;
}

# assume that mbox is good, no error-checking at start
# not sure the message_end is necessary, is that for MMDF?
sub _list_messages {
    my $self = shift;
    if (!-s $self->_spoolfile) {
        # no mail
        return;
    }
    my $seen_message_end = 1; # the end of fake "message 0"...
    my $messagecnt = 0;
    my $messageoctets = 0;
    my $messageuidl = '';
    local *MDROP;
    open MDROP, $self->_spoolfile;
    while () {
        $self->_lock_update;
        s/\r|\n//g;
        if ($seen_message_end and /$self->{MESSAGE_START}/) {
            # tick over
            $self->_close_old_message(
                $messagecnt,
                $messageuidl,
                $messageoctets,
            );
            $messagecnt++;
            $messageuidl = '';
            $messageoctets = 0;
            $self->_start_new_message($messagecnt, $_);
        } else {
            $seen_message_end = 0;
            if (/$self->{MESSAGE_END}/) {
                $seen_message_end = 1;
            }
            if (/^Message-Id:\s*(.+)/ and not $messageuidl) {
                # only take first Message-ID; cf such a header appearing in body
                $messageuidl = $1;
            }
            $self->_push_message($messagecnt, $_);
            $messageoctets += length ($_.$CRLF);
        }
    }
    # catch the last one
    $self->_close_old_message($messagecnt, $messageuidl, $messageoctets);
    $self->{MESSAGECNT} = $messagecnt;
}

sub _spoolfile {
    my $self = shift;
    $self->{SPOOLFILE};
}

sub lock_acquire {
    my $self = shift;
    my $lockfile = $self->_lock_filename;
    return if -f $lockfile;
    $self->{LINE} = 0;
    $self->{LOCK_FH} = IO::File->new(
        ">$lockfile"
    ) or die "open >$lockfile: $!\n";
    unless (flock $self->{LOCK_FH}, LOCK_EX|LOCK_NB) {
        unlink $lockfile;
        return;
    }
    chmod 0600, $lockfile;
    chown $self->{CLIENT_USER_ID}, $self->{MAILGROUP}, $lockfile;
    my $oldfh = select $self->{LOCK_FH};
    $| = 1;
    select $oldfh;
    $self->_lock_refresh;
    # stat the file to get its size, this is checked before closing
    # the mailbox.
    # If the size has changed the lock may have been compromised, so a
    # backup is then made.
    my @filestat = stat $self->_spoolfile;
    $self->{MAILBOX_TIMESTAMP_OPEN} = $filestat[9];
    # set effective UID to user for the rest of the session;
    $> = $self->{CLIENT_USER_ID};
    $self->_list_messages;
die unless $self->{LOCK_FH};
    1;
}

sub lock_release {
    my $self = shift;
    close $self->{LOCK_FH};
    $> = 0;
    unlink $self->_lock_filename;
    $> = $self->{CLIENT_USER_ID};
}

sub _lock_filename {
    my ($self) = @_;
    "$self->{SPOOLFILE}.lock";
}

sub _lock_refresh {
    # This is to update the m time on the .lock mbox lock file.
    # It may seem paranoid but I have seen lock files removed by impatient
    # MDA's, so the file is written-to, unbuffered, as often as is
    # practicable.
    my $self = shift;
    $> = 0;
die unless $self->{LOCK_FH};
    seek $self->{LOCK_FH}, 0, SEEK_SET;
    $self->{LOCK_FH}->print("\0");
    $> = $self->{CLIENT_USER_ID};
}

sub _lock_update {
    my $self = shift;
    if (++$self->{LINE} == 1000) {
        $self->_lock_refresh;
        $self->{LINE} = 0;
    }
}

sub _push_message_line {
    my ($self, $messagecnt, $data) = @_;
    push @{ $self->{MSG2TEXT}->{$messagecnt} }, "$data$CRLF";
}

sub _set_message_line {
    my ($self, $messagecnt, $lineno, $data) = @_;
    $self->{MSG2TEXT}->{$messagecnt}->[$lineno] = $data;
}

sub _get_message_line {
    my ($self, $messagecnt, $lineno) = @_;
    $self->{MSG2TEXT}->{$messagecnt}->[$lineno];
}

sub _unshift_message_line {
    my ($self, $messagecnt, $data) = @_;
    unshift @{ $self->{MSG2TEXT}->{$messagecnt} }, "$data$CRLF";
}

sub _list_message_line {
    my ($self, $messagecnt) = @_;
    @{ $self->{MSG2TEXT}->{$messagecnt} };
}

sub octets {
    my ($self, $message) = @_;
    if (defined $message) {
        $self->{MSG2OCTETS}->{$message};
    } else {
        $self->{TOTALOCTETS} - $self->{DELTOTALOCTETS};
    }
}

sub messages {
    my ($self) = @_;
    $self->{MESSAGECNT} - $self->{DELMESSAGECNT};
}

# Build message arrays or write the next line to disk
sub _push_message {
    my ($self, $messagecnt, $data) = @_;
    $self->_push_message_line($messagecnt, $data);
}

# $message starts at 1
# returns number of bytes
sub top {
    my ($self, $message, $output_fh, $body_lines) = @_;
    my $top_bytes = 0;
    my $rows = (scalar $self->_list_message_line($message)) -1;
    $body_lines = $rows if $body_lines > $rows;
    my $cnt = 0;
    for my $line ($self->_list_message_line($message)) {
        $top_bytes += length($line);
        ++$cnt;
        $self->_lock_update;
        $output_fh->print($line);
        last if $line =~ /^\s*$/;
    }
    for my $lineno ($cnt..(($cnt + $body_lines) -1)) {
        $self->_lock_update;
        my $line = $self->_get_message_line($message, $lineno);
        $top_bytes += length($line);
        $line =~ s/^\./\.\./o;
        $output_fh->print($line);
    }
    $top_bytes;
}

sub flush_delete {
    my ($self) = @_;
    my $spool_mtime = (stat $self->_spoolfile)[9];
    if ($spool_mtime != $self->{MAILBOX_TIMESTAMP_OPEN}) {
        die "spool lock error\n";
    }
    my $spoolfile = $self->_spoolfile;
    open MDROP, '>' . $spoolfile or die "open >$spoolfile: $!\n";
    foreach my $cnt (1..$self->{MESSAGECNT}) {
        if (!$self->is_deleted($cnt)) {
            print MDROP "$self->{MSG2FROMLINE}->{$cnt}\n";
            $self->retrieve($cnt, \*MDROP, 1);
        }
    }
    close MDROP;
}

sub retrieve {
    my ($self, $message, $output_fh, $mbox_destined) = @_;
    for my $line ($self->_list_message_line($message)) {
        $line =~ s/^\./\.\./o unless $mbox_destined;
        $line =~ s/\r$// if $mbox_destined;
        $self->_lock_update;
        $output_fh->print($line);
    }
}

sub uidl {
    my ($self, $message) = @_;
    $self->{MSG2UIDL}->{$message};
}

sub uidl_list {
    my ($self, $output_fh) = @_;
    for (1..$self->{MESSAGECNT}) {
        $self->_lock_refresh;
        if (!$self->is_deleted($_)) {
            $output_fh->print("$_ $self->{MSG2UIDL}->{$_}$CRLF");
        }
    }
    $output_fh->print(".$CRLF");
}

sub is_deleted {
    my ($self, $message) = @_;
    $self->{DELETE}->{$message};
}

sub delete {
    my ($self, $message) = @_;
    $self->_lock_refresh;
    $self->{DELETE}->{$message} = 1;
    $self->{DELMESSAGECNT} += 1;
    $self->{DELTOTALOCTETS} += $self->{MSG2OCTETS}->{$message};
}

sub is_valid {
    my ($self, $msg) = @_;
    $self->_lock_refresh;
    $msg > 0 and $msg <= $self->{MESSAGECNT} and !$self->is_deleted($msg);
}

sub reset {
    my $self = shift;
    $self->_lock_refresh;
    $self->{DELETE} = {};
    $self->{DELMESSAGECNT} = 0;
    $self->{DELTOTALOCTETS} = 0;
}

1;

__END__