File Coverage

blib/lib/File/Extract.pm

Criterion	Covered	Total	%
statement	75	92	81.5
branch	12	30	40.0
condition	2	6	33.3
subroutine	11	13	84.6
pod	5	5	100.0
total	105	146	71.9

# $Id: /mirror/perl/File-Extract/trunk/lib/File/Extract.pm 9350 2007-11-18T13:33:38.729170Z daisuke  $
#
# Copyright (c) 2005-2007 Daisuke Maki
# All rights reserved.

package File::Extract;
use strict;
use warnings;
use base qw(Class::Data::Inheritable);
use File::MMagic::XS qw(:compat);
use File::Temp();
our $VERSION = '0.07000';

sub new
{
    my $class = shift;
    my %args  = @_;

    my $encoding  = $args{output_encoding} || 'utf8';
    my @encodings = $args{encodings} ?
        (ref($args{encodings}) eq 'ARRAY' ? @{$args{encodings}} : $args{encodings}) : ();
    my $self  = bless {
        filters => $args{filters},
        processors => $args{processors},
        magic =>
            $args{file_mmagic_args} ?
                File::MMagic::XS->new(%{$args{file_mmagic_args}}) :
                File::MMagic::XS->new(),
        encodings => \@encodings,
        output_encoding => $encoding
    }, $class;

    return $self;
}

sub magic { shift->{magic} }

sub register_processor
{
    my $class = shift;
    my $pkg   = shift;

    eval "require $pkg" or die;
    my $mime  = $pkg->mime_type;
    $class->RegisteredProcessors->{$mime} ||= [];
    push @{$class->RegisteredProcessors->{$mime}}, $pkg;
}

sub register_filter
{
    my $class = shift;
    my $pkg   = shift;

    eval "require $pkg" or die;
    my $mime  = $pkg->mime_type;
    $class->RegisteredFilter->{$mime} ||= [];
    push @{$class->RegisteredFilter->{$mime}}, $pkg;
}

sub _processors
{
    my $self = shift;
    my $mime = shift;

    my $processors;

    # First, check if we have instance specific processors
    $processors = $self->{processors}{$mime};
    if ($processors) {
        return @$processors;
    }

    $processors = ref($self)->RegisteredProcessors->{$mime};
    if ($processors) {
        return @$processors;
    }

    return ();
}

sub _filters
{
    my $self = shift;
    my $mime = shift;

    my $filters;

    # First, check if we have instance specific filters
    $filters = $self->{filters}{$mime};
    if ($filters) {
        return @$filters;
    }

    $filters = ref($self)->RegisteredFilters->{$mime};
    if ($filters) {
        return @$filters;
    }

    return ();
}

sub extract
{
    my $self  = shift;
    my $file  = shift;

    my $magic = $self->{magic};
    my $mime  = $magic->checktype_filename($file);
    return unless $mime;
    my $o_mime = $mime;

    my $tmp;
    my $source = $file;
    if (my @filters = $self->_filters($mime)) {
        # Filters are applied one after the other, even if that may cause the
        # underlying MIME type to change (i.e. maybe you are crazy enough to
        # apply a filter that changes a plain text file to HTML -- god knows
        # why ;). This may be a bit confusing, since text extractors are
        # applied from the MIME type of the resulting file.
        foreach my $f (@filters) {
            $tmp = File::Temp->new(UNLINK => 1);
            $f->filter(file => $source, output => $tmp);
            $source = $tmp->filename;
        }

        $tmp->flush;
        $mime = $magic->checktype_filename($source);
        return unless $mime;
    }

    if (my @processors = $self->_processors($mime)) {
        foreach my $pkg (@processors) {
            my $p = $pkg->new(
                encodings       => $self->{encodings},
                output_encoding => $self->{output_encoding}
            );
            my $r = eval { $p->extract($source) };

            # Restore the original mime type of the source file. This is
            # required because we might have passed through several filters
            if ($r) {
                if ($source ne $file) {
                    $r->filename($file);
                    $r->mime_type($o_mime);
                }
                return $r;
            }
        }
    }

    return undef;
}

BEGIN
{
    __PACKAGE__->mk_classdata('RegisteredFilters');
    __PACKAGE__->mk_classdata('RegisteredProcessors');
    __PACKAGE__->RegisteredFilters({});
    __PACKAGE__->RegisteredProcessors({});

    my @p = qw(
        File::Extract::Excel
        File::Extract::HTML
        File::Extract::MP3
        File::Extract::PDF
        File::Extract::Plain
        File::Extract::RTF
    );
    foreach my $p (@p) {
        __PACKAGE__->register_processor($p);
    }
}

1;

__END__