Mail::Box significant reducation in memory usage

Hi Mark,

I have some modification to Mail::Box files to help reduce memory usage 
significantly without sacrificing performance (speed). In fact with 
reduced footprint, processing time is reduced significantly on large msgs.

*Background*:

In our environment we process lots of messages. We receive msgs and 
parse them into Message objects and at sometimes serialize them to be 
stored in DB. Performance at times are impacted severely when 
significant size msg come to the system and increased memory footprint 
caused the system to swap a lot.

Because of this I spent time to see if any memory optimization can be 
done. In the end I managed to chop more than half of memory usage just 
by avoiding data copying which many times happen unexpectedly.

For my test case, processing a 27MB msg would originally take as much as 
268 MB in memory (on Message object related processing):

    * 188MB parsing into Message object ($message->readFromParser)
    * 80 MB serializing Message body (FastScalar::Print)

After improvement the same msg size now takes 77 MB

    * 45MB parsing into Message object
    * 32 MB serializing Message body

This was all tested in Perl 5.8.5 environment and Mail::Box 2.056.

FYI, I had Todd Richmond, the original author of FastScalar.pm to look 
at the changes. I also performed as much manual unit testing as I could 
on FastScalar.

I hope you find this mod to be useful and are able to incorporate it as 
you see fit.

Thank you.

Andy Maas

*Summary:*

Changes are in two areas

   1. Avoid twice copying @lines array returned by $file->getlines (in
      Mail::Box::Parser::Perl::_read_stripped_lines line 198) all the
      way up to Mail::Message::Body::Lines::read where it is stored in
      $self->{MMBL_array}- saved 91MB in message parsing
   2. Avoid data copying inside FastScalar.pm - saved 52MB on parsing
      and another 48MB on print (serializing body). Changes are:

          o changed from {data} model to {pos} model (using position
            instead of data buffer to keep current position) - 27MB saving
          o getlines(): avoid unintended data copy - 27MB saving
                + my $data = $self->{data};
          o print(): avoid unnecessary data copying (one on join and one
            for $buf) - 48MB
                + *before*: my $buf = $#_ ? join('', @_) : $_[0]; $$ref
                  .= $buf;
                + *after*: $$ref .= $_ foreach @_;
          o and a couple of bug fix:
                + seek() to handle $whence=2 case correctly
                + write() to return length written for ($len=0) case

Change #1 is minimal so I include it below.
Change #2 is significant and included as attachment of the complete file 
(FastScalar.pm)

*Change #1 Detail*

A. Mail::Message::Body::Lines::read

    Now expect bodyAsList to return array of three things (begin, end, 
lines reference). This change in API semantic is necessary and seems to 
be confined to this one place.

    sub read($$;$@)
    {   my ($self, $parser, $head, $bodytype) = splice @_, 0, 4;
        my @lines = $parser->bodyAsList(@_);
        return undef unless @lines;

        $self->fileLocation(shift @lines, shift @lines);
    /#    $self->{MMBL_array} = \@lines; this is before
    /    *$self->{MMBL_array} = shift @lines; # this is now*
        $self;
    }

B. Mail::Box::Parser::Perl::bodyAsList

    sub bodyAsList(;$$)
    {   my ($self, $exp_chars, $exp_lines) = @_;
        my $file  = $self->{MBPP_file};
        my $begin = $file->tell;

        my ($end, $lines) = $self->_read_stripped_lines($exp_chars,
    $exp_lines);
    /#    ($begin, $end, @$lines); before
    /*    ($begin, $end, $lines); # now
    *}

C. Mail::Box::Parser::Perl::_read_stripped_lines

    Change @lines to $lines

    sub _read_stripped_lines(;$$)
    {   my ($self, $exp_chars, $exp_lines) = @_;
        $exp_lines  = -1 unless defined $exp_lines;
        my @seps    = @{$self->{MBPP_separators}};

        my $file    = $self->{MBPP_file};
        my *$lines*   = *[]*;

        if(@seps && $self->{MBPP_trusted})
        {   my $sep  = $seps[0];
            my $l    = length $sep;

            while(1)
            {   my $where = $file->tell;
                my $line  = $file->getline or last;

                if(   substr($line, 0, $l) eq $sep
                   && ($sep ne 'From ' || $line =~ m/
    (?:19[789]\d|20[01]\d)/)
                   )
                {   $file->seek($where, 0);
                    last;
                }

                push *@$lines*, $line;
            }
        }
        elsif(@seps)
        {

      LINE: while(1)
            {   my $where = $file->getpos;
                my $line  = $file->getline or last;

                foreach my $sep (@seps)
                {   next if substr($line, 0, length $sep) ne $sep;
                    next if $sep eq 'From ' && $line !~ m/
    (?:19[789]\d|20[01]\d)/;

                    $file->setpos($where);
                    last LINE;
                }

                $line =~ s/\015$//;
                push *@$lines*, $line;
            }
        }
        else
        {   # File without separators.
            *$lines* = $file->getlines;
        }

        my $end = $file->tell;
        if($exp_lines > 0 )
        {    while(*@$lines* > $exp_lines && *$lines->[-1]* =~ $empty)
             {   $end -= length *$lines->[-1]*;
                 pop *@$lines*;
             }
        }
        elsif(@seps && *@$lines* && *$lines->[-1]* =~ $empty)
        {   # blank line should be in place before a separator.  Only that
            # line is removed.
            $end -= length *$lines->[-1]*;
            pop *@$lines*;
        }

        map { s/^\>(\>*From\s)/$1/ } *@$lines*
            if $self->{MBPP_strip_gt};

        $end, *$lines*;
    }

package Mail::Box::FastScalar;

use strict;
use warnings;
use integer;

sub new($) {
    my ($class, $ref) = @_;
    $$ref = '' unless defined($$ref);
    my $self = { ref => $ref, pos => 0 };

    bless $self, $class;
    return $self;
}

sub autoflush() {}

sub binmode() {}

sub clearerr { return 0; }

sub flush() {}

sub sync() { return 0; }

sub opened() { return $_[0]->{ref}; }

sub open($) {
    my $self = $_[0];

    ${$_[1]} = '' unless defined(${$_[1]});
    $self->{ref} = $_[1];
    $self->{pos} = 0;
}

sub close() {
    undef $_[0]->{ref};
}

sub eof() {
    my $self = $_[0];

    return $self->{pos} >= length(${$self->{ref}});
}

sub getc() {
    my $self = $_[0];

    return substr(${$self->{ref}}, $self->{pos}++, 1);
}

sub print {
    my $self = shift;
    my $pos = $self->{pos};
    my $ref = $self->{ref};
    my $len = length($$ref);
    
    if ($pos >= $len) {
	$$ref .= $_ foreach @_;
	$self->{pos} = length($$ref);
    } else {
	my $buf = $#_ ? join('', @_) : $_[0];
	
	$len = length($buf);
	substr($$ref, $pos, $len) = $buf;
	$self->{pos} = $pos + $len;
    }
    1;
}

sub read($$;$) {
    my $self = $_[0];
    my $buf = substr(${$self->{ref}}, $self->{pos}, $_[2]);
    $self->{pos} += $_[2];

    ($_[3] ? substr($_[1], $_[3]) : $_[1]) = $buf;
    return length($buf);
}

sub sysread($$;$) {
    return shift()->read(@_);
}

sub seek($$) {
    my $self = $_[0];
    my $whence = $_[2];
    my $len = length(${$self->{ref}});

    if ($whence == 0) {
	$self->{pos} = $_[1];
    } elsif ($whence == 1) {
	$self->{pos} += $_[1];
    } elsif ($whence == 2) {
	$self->{pos} = $len + $_[1];
    } else {
	return;
    }
    if ($self->{pos} > $len) {
	$self->{pos} = $len;
    } elsif ($self->{pos} < 0) {
	$self->{pos} = 0;
    }
    return 1;
}

sub sysseek($$) {
    return $_[0]->seek($_[1], $_[2]);
}

sub setpos($) {
    return $_[0]->seek($_[1], 0);
}

sub sref() {
    return $_[0]->{ref};
}

sub getpos() {
    return $_[0]->{pos};
}

sub tell() {
    return $_[0]->{pos};
}

sub write($$;$) {
    my $self = $_[0];
    my $pos = $self->{pos};
    my $ref = $self->{ref};
    my $len = length($$ref);

    if ($pos >= $len) {
	$$ref .= substr($_[1], $_[3] || 0, $_[2]);
	$self->{pos} = length($$ref);
	$len = $self->{pos} -  $len;
    } else {
	my $buf = substr($_[1], $_[3] || 0, $_[2]);
	
	$len = length($buf);
	substr($$ref, $pos, $len) = $buf;
	$self->{pos} = $pos + $len;
    }
    return $len;
}

sub syswrite($;$$) {
    return shift()->write(@_);
}

sub getline() {
    my $self = $_[0];
    my $ref = $self->{ref};
    my $pos = $self->{pos};

    if (!defined($/) || (my $idx = index($$ref, $/, $pos)) == -1) {
	return if ($pos >= length($$ref));
	$self->{pos} = length($$ref);
	return substr($$ref, $pos);
    } else {
	return substr($$ref, $pos, ($self->{pos} = $idx + length($/)) - $pos);
    }
}

sub getlines() {
    my $self = $_[0];
    my @lines;
    my $ref = $self->{ref};
    my $pos = $self->{pos};

    if (defined($/)) {
	my $idx;
	
	while (($idx = index($$ref, $/, $pos)) != -1) {
	    push(@lines, substr($$ref, $pos, ($idx + 1) - $pos));
	    $pos = $idx + 1;
	}
    }
    my $r = substr($$ref, $pos);
    if (length($r) > 0) {
	push(@lines, $r);
    }
    $self->{pos} = length($$ref);
    return wantarray() ? @lines : \@lines;
}

sub TIEHANDLE {
    ((defined($_[1]) && UNIVERSAL::isa($_[1], "Mail::Box::FastScalar"))
         ? $_[1] : shift->new(@_));
}

sub GETC { shift()->getc(@_) }
sub PRINT { shift()->print(@_) }
sub PRINTF { shift()->print(sprintf(shift, @_)) }
sub READ { shift()->read(@_) }
sub READLINE { wantarray ? shift()->getlines(@_) : shift()->getline(@_) }
sub WRITE { shift()->write(@_); }
sub CLOSE { shift()->close(@_); }
sub SEEK { shift()->seek(@_); }
sub TELL { shift()->tell(@_); }
sub EOF { shift()->eof(@_); }

1;