The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Email::Store::Attachment;
use base "Email::Store::DBI";
use strict;
use MIME::Parser;
__PACKAGE__->table("attachment");
__PACKAGE__->columns(All => qw[ id mail filename content_type payload ]);
__PACKAGE__->has_a(mail => "Email::Store::Mail");
Email::Store::Mail->has_many(attachments => "Email::Store::Attachment");


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

    my $id     = $mail->message_id;
    my $rfc822 = $mail->message;
    my $parser = MIME::Parser->new();

    $parser->output_to_core('ALL');
    $parser->extract_nested_messages(0);

    my $entity = $parser->parse_data($rfc822);

    my @keep;
    for ($entity->parts) {
        push (@keep, $_) && next if keep_part($_);
        my $type    = $_->effective_type;
        my $file    = $_->head->recommended_filename() || invent_filename($type);
        my $payload = $_->bodyhandle->as_string;
        $class->create({ mail => $id,  payload => $payload, content_type => $type, filename => $file });
    }
    $entity->parts(\@keep);
    $entity->make_singlepart;

    $mail->message($entity->as_string);
    undef $mail->{simple}; # Invalidate cache
    $mail->update;
}

sub on_store_order { 1 }

my $gname = 0;

sub invent_filename {
    my ($ct) = @_;
    require MIME::Types;
    my $type = MIME::Types->new->type($ct);
    my $ext = $type && (($type->extensions)[0]);
    $ext ||= "dat";
    return "attachment-$$-".$gname++.".$ext";
}


sub keep_part {
    my $p = shift;
    my $fn = $_->head->recommended_filename();
    my $ct = $p->effective_type                   || 'text/plain';
    my $dp = $p->head->get('Content-Disposition') || 'inline';
    return $ct =~ m[text/plain] && $dp =~ /inline/ && (!defined $fn or $fn =~ /^\s*$/);
}


1;

=head1 NAME

Email::Store::Attachment - Split attachments from mails

=head1 SYNOPSIS

    my @attachments = $mail->attachments;
    for (@attachments) {
        print $_->filename, $_->content_type, $_->payload;
    }

=head1 DESCRIPTION

This plug-in adds the concept of an attachment. At index time, it
removes all attachments from the mail, and stores them in a separate
attachments table. This records the C<filename>, C<content_type> and
C<payload> of the attachments, and each mail's attachments can be
reached through the C<attachments> accessor. The text of the mail,
sans attachments, is replaced into the mail table.

=head1 WARNING

If your database requires you to turn on some attribute for encoding
binary nulls, you need to do this in your call to C<use Email::Store>.

=cut

__DATA__

CREATE TABLE IF NOT EXISTS attachment (
    id           integer NOT NULL PRIMARY KEY AUTO_INCREMENT,
    mail         varchar(255),
    payload      text,
    filename     varchar(255),
    content_type varchar(255)
);