libarchive-any-lite-perl 0.07-1 / usr / share / perl5 / Archive / Any / Lite.pm

package Archive::Any::Lite;

use strict;
use warnings;
use File::Spec;

our $VERSION = '0.07';
our $IGNORE_SYMLINK;

sub new {
  my ($class, $file) = @_;

  $file = File::Spec->rel2abs($file);
  unless (-f $file) {
    warn "$file not found\n";
    return;
  }

  # XXX: trust file extensions until I manage to make File::MMagic
  #      more reliable while fork()ing or I happen to find a decent
  #      and portable alternative to File::MMagic.

  my $handler =
    $file =~ /\.(?:tar|tar\.(?:gz|bz2)|gtar|tgz)$/ ? 'Archive::Any::Lite::Tar' :
    $file =~ /\.(?:zip)$/ ? 'Archive::Any::Lite::Zip' : undef;
  unless ($handler) {
    warn "No handler available for $file\n";
    return;
  }

  bless {
    file    => $file,
    handler => $handler,
  }, $class;
}

sub extract {
  my ($self, $dir) = @_;

  $self->{handler}->extract($self->{file}, $dir);
}

sub files {
  my $self = shift;
  $self->{handler}->files($self->{file});
}

sub is_impolite {
  my $self = shift;

  my @files       = $self->files;
  my $first_file  = $files[0];
  my ($first_dir) = File::Spec->splitdir($first_file);

  return grep( !/^\Q$first_dir\E/, @files ) ? 1 : 0;
}

sub is_naughty {
  my ($self) = shift;
  return ( grep { m{^(?:/|(?:\./)*\.\./)} } $self->files ) ? 1 : 0;
}

sub type {
  my $self = shift;
  my ($type) = lc $self->{handler} =~ /::(\w+)$/;
  return $type;
}

package Archive::Any::Lite::Tar;
use Archive::Tar;

sub files {
  my ($self, $file) = @_;
  Archive::Tar->list_archive($file);
}

sub extract {
  my ($self, $file, $dir) = @_;
  $dir = '.' unless defined $dir;
  my $tar = Archive::Tar->new;
  my $fh;
  if ($file =~ /\.(tgz|tar\.gz)$/) {
    require IO::Zlib;
    $fh = IO::Zlib->new($file, "rb") or do { warn "$file: $!"; return };
  }
  elsif ($file =~ /\.tar.bz2$/) {
    require IO::Uncompress::Bunzip2;
    $fh = IO::Uncompress::Bunzip2->new($file) or do { warn "$file: $!"; return };
  }
  else {
    open $fh, '<', $file or do { warn "$file: $!"; return };
    binmode $fh;
  }

  # Archive::Tar is too noisy when an archive has minor glitches.
  # Note also that $file can't hold the last error.
  local $Archive::Tar::WARN;
  my %errors;
  my $has_extracted;
  until (eof $fh) {
    my @files = $tar->read($fh, undef, {limit => 1});
    if (my $error = $tar->error) {
      warn $error unless $errors{$error}++;
    }
    if (!@files && !$has_extracted) {
      warn "No data could be read from $file";
      return;
    }
    for my $file (@files) {
      next if $IGNORE_SYMLINK && ($file->is_symlink or $file->is_hardlink);
      my $path = File::Spec->catfile($dir, $file->prefix, $file->name);
      $tar->extract_file($file, File::Spec->canonpath($path)) or do {
        if (my $error = $tar->error) {
          warn $error unless $errors{$error}++;
        }
      };
    }
    $has_extracted += @files;
  }
  return if %errors;
  return 1;
}

sub type { 'tar' }

package Archive::Any::Lite::Zip;
use Archive::Zip qw/:ERROR_CODES/;

sub files {
  my ($self, $file) = @_;
  my $zip = Archive::Zip->new($file) or return;
  $zip->memberNames;
}

sub extract {
  my ($self, $file, $dir) = @_;
  my $zip = Archive::Zip->new($file) or return;
  $dir = '.' unless defined $dir;
  my $error = 0;
  for my $member ($zip->members) {
    next if $IGNORE_SYMLINK && $member->isSymbolicLink;
    my $path = File::Spec->catfile($dir, $member->fileName);
    my $ret = $member->extractToFileNamed(File::Spec->canonpath($path));
    $error++ if $ret != AZ_OK;
  }
  return if $error;
  return 1;
}

sub type { 'zip' }

1;

__END__

=head1 NAME

Archive::Any::Lite - simple CPAN package extractor

=head1 SYNOPSIS

    use strict;
    use warnings;
    use Archive::Any::Lite;

    local $Archive::Any::Lite::IGNORE_SYMLINK = 1; # for safety

    my $tarball = 'foo.tar.gz';
    my $archive = Archive::Any::Lite->new($tarball);
    $archive->extract('into/some/directory/');

=head1 DESCRIPTION

This is a fork of L<Archive::Any> by Michael Schwern and Clint Moore. The main difference is this works properly even when you fork(), and may require less memory to extract a tarball. On the other hand, this isn't pluggable (this only supports file formats used in the CPAN toolchains), and this doesn't check mime types (at least as of this writing).

=head1 METHODS

=head2 new

  my $archive = Archive::Any->new($archive_file);

Creates an object.

=head2 extract

  $archive->extract;
  $archive->extract($directory);

Extracts the files in the archive to the given $directory. If no $directory is given, it will go into the current working directory.

=head2 files

  my @file = $archive->files;

A list of files in the archive.

=head2 is_impolite

  my $is_impolite = $archive->is_impolite;

Checks to see if this archive is going to unpack into the current directory rather than create its own.

=head2 is_naughty

  my $is_naughty = $archive->is_naughty;

Checks to see if this archive is going to unpack outside the current directory.

=head2 type

Deprecated. For backward compatibility only.

=head1 GLOBAL VARIABLE

=head2 $IGNORE_SYMLINK

If set to true, symlinks (and hardlinks for tarball) will be ignored.

=head1 SEE ALSO

L<Archive::Any>, L<Archive::Tar::Streamed>

=head1 AUTHOR

L<Archive::Any> is written by Michael G Schwern and Clint Moore.

Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2012 by Kenichi Ishigaki.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut