File Coverage

blib/lib/MIME/Expander.pm

Criterion	Covered	Total	%
statement	163	163	100.0
branch	64	74	86.4
condition	33	45	73.3
subroutine	25	25	100.0
pod	9	11	81.8
total	294	318	92.4

package MIME::Expander;

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

use vars qw($DEBUG);
$DEBUG = 0;

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';

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 debug {
    my $self = shift;
    my $msg = shift or return;
    printf STDERR "# %s: %s\n", $self, $msg if( $DEBUG );
}

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( $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);
    }

    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 = ($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 ){
        $self->debug("====> shift media, remains=[@{[ scalar @medias ]}]");

        my $type    = $media->content_type;
        my $plugin  = $self->plugin_for($type);
        $self->debug("* type is [$type], plugin_for [@{[ $plugin || '' ]}]");

        if( $limit or $self->is_expected( $type ) or ! $plugin ){
            # expected or un-expandable data
            $self->debug("=> limited, expected or un-expandable data");
            $callback->($media) if( ref $callback eq 'CODE' );
            ++$c;
        }else{
            # expand more
            $self->debug("==> expand more");
            # note: undocumented api is used ->{body}
            $plugin->expand( $media->{body} , sub {
                push @medias, $self->_create_media( @_ );
            });
        }

        ++$ptr;
        $self->debug("incremented ptr=[$ptr] | bound=[$bound] level=[$level]");
        if( $bound <= $ptr ){

            if( $self->depth and $self->depth <= $level ){
                $limit = 1;
                $self->debug("set limit to TRUE");
            }
            $bound += scalar @medias;
            ++$level;
            $self->debug("updated bound=[$bound] level=[$level]");
        }
    }

    return $c;
}


1;
__END__