source: trunk/soft/ObsData/ObsData/Archive.pm @ 240

# $Id$

package ObsData::Archive;

use strict;
use warnings;
require ObsData::Archive::FlatFile;
require ObsData::Archive::Compressed;
require ObsData::Archive::Tar;
require ObsData::Archive::Zip;
require ObsData::Archive::Rar;
require ObsData::Archive::Lha;

our $CVSID = q$Id$;
our $CVSREV = (q$Revision$ =~ /^Revision: (.*) $/)[0];

my $error = {};

my @dynload = ();

sub register {
    my ($rule, $class, $priority) = @_;
    push(
        @ObsData::Archive::dynload,
        {
            rule => $rule,
            class => $class,
            priority => $priority,
        }
    );
    1;
}

sub load_format {
    my ($module) = @_;
    eval { require $module };
    return($@ ? 0 : 1);
}

sub new {
    my ($class, $archive, %options) = @_;
    my $beclass;

    if (!$archive) {
        seterror("No archive to read");
        return undef;
    }
    if (!-r $archive) {
        seterror("No such file or directory");
        return undef;
    }
    my $o;
    
    foreach (keys %options) {
        $o->{$_} = $options{$_};
    }
    $o->{archive} = $archive;
    
    for ($archive) {
        foreach my $r (sort { $a->{priority} <=> $b->{priority} } @ObsData::Archive::dynload) {
            if (ref($r->{rule}) eq 'CODE' ?
                $r->{rule}->($_) :
                /$r->{rule}/) {
                $beclass = $r->{class};
                last;
            }
        }
    }
    
    if ($beclass) {
        my $obj;
        # eval("require $class\:\:$beclass;");
        eval("\$obj = $class\:\:$beclass->new(\$o);");
        return $obj;
    }
}

### Global functions

sub error {
    return $error->{error};
}

sub seterror {
    my ($package, $filename, $line) = caller;
    $error = {
        'package' => $package,
        'filename' => $filename,
        'line' => $line,
        'error' => $_[1] || $_[0],
    };
}

package ObsData::Archive::template;

our @ISA = qw(ObsData::Archive);

sub new {
    my ($class, $o) = @_;
    bless($o, $class);
}

sub DESTROY {
    my ($self) = @_;
}

sub ls {
    my ($self) = @_;
    seterror("ls not implement in class " . ref($self));
    return;
}

sub extract {
    my ($self, $file, $dest) = @_;
    seterror("extract not implement in class " . ref($self));
    return;
}

### Private method

sub _tempdir {
    my ($self) = @_;
    $self->{tmpdir} || $ENV{TMPDIR}
}

1;

__END__

=head1 NAME

ObsData::Archive - Transparently extract files from arbitrary archives

=head1 SYNOPSIS

    use ObsData::Archive;
    my $file = "foo.tar.gz";
    my $oa = ObsData::Archive->new($file) or die ObsData::Archive->error;
    my @content = $oa->ls;
    foreach (@content) {
        $oa->extract($_, "./$_") or die ObsData::Archive->error;
    }

=head1 METHODS

=head2 new($file, %options)

Create a new archive object by reading $file.

Return undef on error and set error status.
See L<error>.

=head2 ls

list the content of the archive

=head2 extract

Extract a file from the archive and return the filename of extract file

=head1 CLASS METHODS

=head2 error

Return the last error encoutered

=head1 AUTHORS

Olivier Thauvin <olivier.thauvin@aerov.jussieu.fr>

=cut