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

# $Id$

package ObsData::Archive;

use strict;
use warnings;
use File::Copy;
use File::Temp qw/ tempfile /;
use ObsData::Archive::Compressed;
use ObsData::Archive::Tar;
use ObsData::Archive::Zip;

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

my $error = {};

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) {
        /\.tar(\.[^\.]*)?$/ and do {
            $beclass = 'Tar';
            last;
        };
        /\.(gz|bz2|Z)$/ and do {
            $beclass = 'Compressed';
            last;
        };
        /\.zip$/ and do {
            $beclass = 'Zip';
            last;
        };
    }
    
    if ($beclass) {
        my $obj;
        # eval("require $class\:\:$beclass;");
        eval("\$obj = $class\:\:$beclass->new(\$o);");
        return $obj;
    } else {
        bless($o, $class);
    }
}

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

sub ls {
    my ($self) = @_;
    my ($file) = $self->{archive} =~ m!^(?:.*/)?(.*)!;
    return $file;
}

sub extract {
    my ($self, $file, $dest) = @_;
    # the devel should specify the file he want
    # as the basic contains only 1 file... this does not matter

    my ($fh, $fname);
    
    if ($dest) {
        $fname = $dest;
        if(!open($fh, '>', $dest)) {
            $error = $!;
            return undef;
        }
    } else {
        ($fh, $fname) = tempfile(
            DIR => $self->_tempdir,
            UNLINK => 1,
        ) or do {
            seterror("Can't create tempfile: $!");
            return undef;
        };
    }
    
    if(!copy($self->{archive}, $fh)) {
        unlink($fname);
        seterror("Cant copy the archive: $!");
        return undef;
    }
    
    close($fh);
    $fname
}

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

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

### 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