File Coverage

blib/lib/Email/Folder/Mbox.pm

Criterion	Covered	Total	%
statement	129	141	91.4
branch	42	64	65.6
condition	15	21	71.4
subroutine	16	17	94.1
pod	3	5	60.0
total	205	248	82.6

use strict;
use warnings;
package Email::Folder::Mbox;
# ABSTRACT: reads raw RFC822 mails from an mbox file
$Email::Folder::Mbox::VERSION = '0.859';
use Carp;
use IO::File;
use Email::Folder::Reader;
use parent 'Email::Folder::Reader';

#pod =head1 SYNOPSIS
#pod
#pod This isa Email::Folder::Reader - read about its API there.
#pod
#pod =head1 DESCRIPTION
#pod
#pod Does exactly what it says on the tin - fetches raw RFC822 mails from an
#pod mbox.
#pod
#pod The mbox format is described at http://www.qmail.org/man/man5/mbox.html
#pod
#pod We attempt to read an mbox as through it's the mboxcl2 variant,
#pod falling back to regular mbox mode if there is no C
#pod header to be found.
#pod
#pod =head2 OPTIONS
#pod
#pod The new constructor takes extra options.
#pod
#pod =over
#pod
#pod =item C
#pod
#pod When filename is set to C<"FH"> than Email::Folder::Mbox will read mbox
#pod archive from filehandle C instead from disk file C.
#pod
#pod =item C
#pod
#pod This indicates what the line-ending style is to be.  The default is
#pod C<"\n">, but for handling files with mac line-endings you would want
#pod to specify C "\x0d">
#pod
#pod =item C
#pod
#pod The value is taken as a boolean that governs what is used match as a
#pod message separator.
#pod
#pod If false we use the mutt style
#pod
#pod  /^From \S+\s+(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)/
#pod  /^From (?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)/;
#pod
#pod If true we use
#pod
#pod  /^From /
#pod
#pod In deference to this extract from L
#pod
#pod   Essentially the only safe way to parse that file format is to
#pod   consider all lines which begin with the characters ``From ''
#pod   (From-space), which are preceded by a blank line or
#pod   beginning-of-file, to be the division between messages.  That is, the
#pod   delimiter is "\n\nFrom .*\n" except for the very first message in the
#pod   file, where it is "^From .*\n".
#pod
#pod   Some people will tell you that you should do stricter parsing on
#pod   those lines: check for user names and dates and so on.  They are
#pod   wrong.  The random crap that has traditionally been dumped into that
#pod   line is without bound; comparing the first five characters is the
#pod   only safe and portable thing to do. Usually, but not always, the next
#pod   token on the line after ``From '' will be a user-id, or email
#pod   address, or UUCP path, and usually the next thing on the line will be
#pod   a date specification, in some format, and usually there's nothing
#pod   after that.  But you can't rely on any of this.
#pod
#pod Defaults to false.
#pod
#pod =item C
#pod
#pod This boolean value indicates whenever lines which starts with
#pod
#pod  /^>+From /
#pod
#pod should be unescaped (= removed leading '>' char). This is needed for
#pod mboxrd and mboxcl variants. But there is no way to detect for used mbox
#pod variant, so default value is false.
#pod
#pod =item C
#pod
#pod Seek to an offset when opening the mbox.  When used in combination with
#pod ->tell you may be able to resume reading, with a trailing wind.
#pod
#pod =item
#pod
#pod This returns next message as string
#pod
#pod =item
#pod
#pod This returns next message as ref to string
#pod
#pod =item C
#pod
#pod This returns the current filehandle position in the mbox.
#pod
#pod =item C
#pod
#pod This returns the From_ line for next message. Call it before ->next_message.
#pod
#pod =back
#pod
#pod =cut

sub defaults {
    ( eol => "\n")
}

sub _open_it {
    my $self = shift;
    my $file = $self->{_file};
    my $fh = $self->{fh};

    unless ($file eq "FH" and $fh) {
        # sanity checking
        croak "$file does not exist" unless (-e $file);
        croak "$file is not a file"  unless (-f $file);

        local $/ = $self->{eol};
        $fh = $self->_get_fh($file);
    }

    if (seek $fh, tell($fh), 0) {
        # Enable using seek only if $fh is seekable
        $self->{seekable} = 1;
    } else {
        # Otherwise use cache for simulating backward seeks
        $self->{cache} = [];
    }

    if ($self->{seek_to}) {
        unless ($self->{seekable}) {
            croak "$file is not seekable but seek_to was set";
        }
        # we were told to seek.  hope it all goes well
        seek $fh, $self->{seek_to}, 0;
    }
    else {
        local $/ = $self->{eol};
        my $firstline = <$fh>;
        if ($firstline) {
            croak "$file is not an mbox file" unless $firstline =~ /^From /;
        }
        $self->{from} = $firstline;
    }

    $self->{_fh} = $fh;
}

sub _get_fh {
    my $self = shift;
    my $file = shift;
    my $fh = IO::File->new($file) or croak "Cannot open $file";
    binmode($fh);
    return $fh;
}

sub _read_nextline {
    my $self = shift;
    if (not $self->{seekable} and @{$self->{cache}}) {
        return shift @{$self->{cache}};
    }
    my $fh = $self->{_fh};
    return <$fh>;
}

use constant debug => 0;
my $count;

sub next_from {
    my $self = shift;
    $self->_open_it unless $self->{_fh};
    return $self->{from};
}

sub next_messageref {
    my $self = shift;

    my $fh = $self->{_fh} || $self->_open_it;
    local $/ = $self->{eol};

    my $mail = '';
    my $prev = '';
    my $last;
    my $inheaders = 1;
    ++$count;
    print "$count starting scanning at line $.\n" if debug;

    while (my $line = _read_nextline($self)) {
        if ($line eq $/ && $inheaders) { # end of headers
            print "$count end of headers at line $.\n" if debug;
            $inheaders = 0; # stop looking for the end of headers
            my $pos; # where to go back to if it goes wrong
            $pos = tell $fh if $self->{seekable};

            # look for a content length header, and try to use that
            if ($mail =~ m/^Content-Length:\s*(\d+)$/mi) {
                my @cache;
                $mail .= $prev;
                $prev = '';
                my $length = $1;
                print " Content-Length: $length\n" if debug;
                my $read = '';
                while (my $bodyline = _read_nextline($self)) {
                    push @cache, $bodyline unless $self->{seekable};
                    last if length $read >= $length;
                    # unescape From_
                    $bodyline =~ s/^>(>*From )/$1/ if $self->{unescape};
                    $read .= $bodyline;
                }
                # grab the next line (should be /^From / or undef)
                my $next = _read_nextline($self);
                if (!defined $next || $next =~ /^From /) {
                    $self->{from} = $next;
                    $mail .= "$/$read";
                    return \$mail;
                }
                push @cache, $next unless $self->{seekable};
                # seek back and scan line-by-line like the header
                # wasn't here
                print " Content-Length assertion failed '$next'\n" if debug;
                if ($self->{seekable}) {
                    seek $fh, $pos, 0;
                }
                else {
                    unshift @{$self->{cache}}, @cache;
                }
            }

            # much the same, but with Lines:
            if ($mail =~ m/^Lines:\s*(\d+)$/mi) {
                my @cache;
                $mail .= $prev;
                $prev = '';
                my $lines = $1;
                print " Lines: $lines\n" if debug;
                my $read = '';
                for (1 .. $lines) {
                    my $bodyline = _read_nextline($self);
                    last unless defined $bodyline;
                    push @cache, $bodyline unless $self->{seekable};
                    # unescape From_
                    $bodyline =~ s/^>(>*From )/$1/ if $self->{unescape};
                    $read .= $bodyline;
                }
                my $ign = _read_nextline($self); # trailing newline
                my $next = _read_nextline($self);
                if (!defined $next || $next =~ /^From /) {
                    $self->{from} = $next;
                    $mail .= "$/$read";
                    return \$mail;
                }
                push @cache, $ign, $next unless $self->{seekable};
                # seek back and scan line-by-line like the header
                # wasn't here
                print " Lines assertion failed '$next'\n" if debug;
                if ($self->{seekable}) {
                    seek $fh, $pos, 0;
                }
                else {
                    unshift @{$self->{cache}}, @cache;
                }
            }
        }

        if ($prev eq $/ && ($line =~ $self->_from_line_re)) {
            $mail .= $prev;
            $last = $line;
            last;
        }

        $mail .= $prev;
        $prev = $line;

        # unescape From_
        $prev =~ s/^>(>*From )/$1/ if $self->{unescape};
    }
    print "$count end of message line $.\n" if debug;
    $self->{from} = $last;
    return unless $mail;
    return \$mail;
}

sub next_message {
    my $self = shift;
    my $ref = $self->next_messageref;
    return unless $ref;
    return ${$ref};
}

my @FROM_RE;
BEGIN {
  @FROM_RE = (
    # according to mutt:
    #   A valid message separator looks like:
    #   From [  ]     [  ]
    qr/^From (?:\S+\s+)?(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)/,

    # though, as jwz rants, only this is reliable and portable
    qr/^From /,
  );
}

sub _from_line_re {
  return $FROM_RE[ $_[0]->{jwz_From_} ? 1 : 0 ];
}

sub tell {
    my $self = shift;
    return tell $self->{_fh};
}

1;

__END__