File Coverage

blib/lib/MIME/Expander.pm

Criterion	Covered	Total	%
statement	159	159	100.0
branch	66	74	89.1
condition	33	46	71.7
subroutine	25	25	100.0
pod	10	11	90.9
total	293	315	93.0

package MIME::Expander;

use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '0.02';

use vars qw($PrefixGuess $PrefixPlugin @DefaultGuesser @EnabledPlugins);
BEGIN {
    $PrefixGuess    = 'MIME::Expander::Guess';
    $PrefixPlugin   = 'MIME::Expander::Plugin';
    @DefaultGuesser = ('MMagic', 'FileName');
    @EnabledPlugins = ();
}

use Email::MIME;
use Email::MIME::ContentType ();
use MIME::Type;
use Module::Load;
use Module::Pluggable search_path => $PrefixPlugin, sub_name => 'expanders';
use MIME::Expander::Plugin::MessageRFC822;
use Scalar::Util 'blessed';

sub import {
    my $class = shift;
    @EnabledPlugins = @_;
}

sub regulate_type {
    return undef unless( defined $_[1] );
    my $type = $_[1];

    # There is regexp from Email::MIME::ContentType 1.015
    my $tspecials = quotemeta '()<>@,;:\\"/[]?=';
    my $discrete  = qr/[^$tspecials]+/;
    my $composite = qr/[^$tspecials]+/;
    my $params    = qr/;.*/;
    return undef unless( $type =~ m[ ^ ($discrete) / ($composite) \s* ($params)? $ ]x );

    my $ct = Email::MIME::ContentType::parse_content_type($type);
    return undef if( ! $ct->{discrete} or ! $ct->{composite} );
    return MIME::Type->simplified(join('/',$ct->{discrete}, $ct->{composite}));
}

sub new {
    my $class = shift;
    $class = ref $class || $class;
    my $self = {
        expects     => [],
        guesser     => undef,
        depth       => undef,
        };
    bless  $self, $class;
    return $self->init(@_);
}

sub init {
    my $self = shift;
    my $args;
    if( 0 == @_ % 2 ){
        $args = { @_ }
    }else{
        $args = shift || {};
    }

    $self->expects(
        exists $args->{expects} ? $args->{expects} : [] );

    $self->guesser(
        exists $args->{guesser} ? $args->{guesser} : undef );

    $self->depth(
        exists $args->{depth} ? $args->{depth} : undef );

    return $self;
}

sub expects {
    my $self = shift;
    if( @_ ){
        $self->{expects} = shift;
        die "setting value is not acceptable, it requires an reference of ARRAY"
            if( defined $self->{expects} and ref($self->{expects}) ne 'ARRAY' );
    }
    return $self->{expects};
}

sub is_expected {
    my $self = shift;
    my $type = shift or undef;
    die "invalid type $type that has not looks as mime/type"
        if( $type !~ m,^.+/.+$, );
    return () unless( $self->expects );
    for my $regexp ( map { ref $_ ? $_ : qr/$_/ } @{$self->expects} ){
        return 1 if( $type =~ $regexp );
    }
    return ();
}

sub depth {
    my $self = shift;
    if( @_ ){
        $self->{depth} = shift;
        die "setting value is not acceptable, it requires a native number"
            if( defined $self->{depth} and $self->{depth} =~ /\D/ );
    }
    return $self->{depth};
}

sub guesser {
    my $self = shift;
    if( @_ ){
        $self->{guesser} = shift;
        die "setting value is not acceptable, it requires an reference of CODE or ARRAY"
            if( defined $self->{guesser}
            and ref($self->{guesser}) ne 'CODE'
            and ref($self->{guesser}) ne 'ARRAY');
    }
    return $self->{guesser};
}

sub guess_type_of {
    my $self     = shift;
    my $ref_data = shift or die "missing mandatory parameter";
    my $info     = shift || {};

    my $type    = undef;
    my $routine = $self->guesser;

    if(     ref $routine eq 'CODE' ){
        $type = $self->guesser->($ref_data, $info);

    }else{
        my @routines;
        if( ref $routine eq 'ARRAY' ){
            @routines = @$routine;
        }else{
            @routines = @DefaultGuesser;
        }
        for my $klass ( @routines ){
            $klass = join('::', $PrefixGuess, $klass) if( $klass !~ /:/ );
            Module::Load::load $klass;
            $type = $self->regulate_type( $klass->type($ref_data, $info) );
            last if( $type and $type ne 'application/octet-stream');
        }
    }
    return ($type || 'application/octet-stream');
}

sub plugin_for {
    my $self = shift;
    my $type = shift;

    my $plugin = undef;
    for my $available ( $self->expanders ){

        my $klass = undef;
        unless( @EnabledPlugins ){
            $klass = $available;
        }else{
            for my $enable ( @EnabledPlugins ){
                $enable = join('::', $PrefixPlugin, $enable)
                    if( $enable !~ /:/ );
                if( $available eq $enable ){
                    $klass = $available;
                    last;
                }
            }
            next unless( $klass );
        }

        Module::Load::load $klass;
        if( $klass->is_acceptable( $self->regulate_type($type) ) ){
            $plugin = $klass->new;
            last;
        }
    }
    return $plugin;
}

sub create_media {
    my $self     = shift;
    my $ref_data = shift or die "missing mandatory parameter";
    my $info     = shift || {};

    my $type = $self->regulate_type($info->{content_type});
    if( ! $type or $type eq 'application/octet-stream' ){
        $type = $self->guess_type_of($ref_data, $info);
    }

    if( MIME::Expander::Plugin::MessageRFC822->is_acceptable(
        $self->regulate_type($type)
    )){
        return Email::MIME->new($ref_data);
    }else{
        return Email::MIME->create(
            attributes => {
                content_type    => $type,
                encoding        => 'binary',
                filename        => $info->{filename},
                },
            body => $ref_data,
            );
    }
}

sub walk {
    my $self        = shift;
    my $data        = shift;
    my $callback    = shift;
    my $info        = shift || {};
    my $c           = 0;

    my @medias = ();
    if( blessed($data) and $data->isa('Email::Simple') ){
        push @medias, $data;
    }else{
        @medias = ($self->create_media(
            ref $data eq 'SCALAR' ? $data : \$data,
            $info));
    }

    # reset vars for depth option
    my $ptr     = 0;
    my $limit   = 0;
    my $level   = 1;
    my $bound   = scalar @medias;

    # when expandable contents, then append it to @medias
    while( my $media = shift @medias ){
        my $type    = $media->content_type;
        my $plugin  = $self->plugin_for($type);
        if( $limit or $self->is_expected( $type ) or ! $plugin ){
            # expected or un-expandable data
            $callback->($media) if( ref $callback eq 'CODE' );
            ++$c;
        }else{
            # expand more
            $plugin->expand( $media , sub {
                push @medias, $self->create_media( @_ );
            });
        }

        ++$ptr;
        if( $bound <= $ptr ){
            if( $self->depth and $self->depth <= $level ){
                $limit = 1;
            }
            $bound += scalar @medias;
            ++$level;
        }
    }

    return $c;
}


1;
__END__