view release on metacpan or  search on metacpan

lib/Archive/SevenZip.pm  view on Meta::CPAN

package Archive::SevenZip;
use strict;
use warnings;
use Carp qw(croak);
use Encode qw( decode encode );
use File::Basename qw(dirname basename);
use Archive::SevenZip::Entry;
use File::Temp qw(tempfile tempdir);
use File::Copy;
use IPC::Open3 'open3';
use Path::Class;
use Exporter 'import'; # for the error codes, in Archive::Zip API compatibility

=head1 NAME

Archive::SevenZip - Read/write 7z , zip , ISO9960 and other archives

=head1 SYNOPSIS

  my $ar = Archive::SevenZip->new(
      find => 1,
      archivename => $archivename,
      verbose => $verbose,
  );

  for my $entry ( $ar->list ) {
      my $target = join "/", "$target_dir", $entry->basename;
      $ar->extractMember( $entry->fileName, $target );
  };

=head1 METHODS

=cut

our $VERSION= '0.20';

# Archive::Zip API
# Error codes
use constant AZ_OK           => 0;

use constant COMPRESSION_STORED        => 'Store';   # file is stored (no compression)
use constant COMPRESSION_DEFLATED      => 'Deflate';   # file is Deflated

our @EXPORT_OK = (qw(AZ_OK COMPRESSION_STORED COMPRESSION_DEFLATED));
our %EXPORT_TAGS = (
        ERROR_CODES => [
            qw(
              AZ_OK
              )
              #AZ_STREAM_END
              #AZ_ERROR
              #AZ_FORMAT_ERROR
              #AZ_IO_ERROR
        ],
        CONSTANTS => [
             qw(COMPRESSION_STORED COMPRESSION_DEFLATED)
        ],
);

our %sevenzip_charsetname = (
    'UTF-8' => 'UTF-8',
    'Latin-1' => 'WIN',
    'ISO-8859-1' => 'WIN',
    '' => 'DOS', # dunno what the appropriate name would be
);

our %sevenzip_stdin_support = (
    #'7z'   => 1,
    'xz'    => 1,
    'lzma'  => 1,
    'tar'   => 1,
    'gzip'  => 1,
    'bzip2' => 1,
);

if( $^O !~ /MSWin/i ) {
    # Wipe all filesystem encodings because my Debian 7z 9.20 doesn't understand them
    $sevenzip_charsetname{ $_ } = ''
        for keys %sevenzip_charsetname;
};

our %class_defaults = (
    '7zip' => '7z',
    fs_encoding => 'UTF-8',
    default_options => [ "-y", "-bd" ],
    type => 'zip',
    system_needs_quotes => scalar ($^O =~ /MSWin/i),
);

=head2 C<< Archive::SevenZip->find_7z_executable >>

    my $version = Archive::SevenZip->find_7z_executable()
        or die "No 7z found.";
    print "Found 7z version '$version'";

Finds the 7z executable in the path or in C<< $ENV{ProgramFiles} >>
or C<< $ENV{ProgramFiles(x86)} >>. This is called
when a C<< Archive::SevenZip >> instance is created with the C<find>
parameter set to 1.

If C<< $ENV{PERL_ARCHIVE_SEVENZIP_BIN} >> is set, this value will be used as
the 7z executable and the path will not be searched.

=cut

sub find_7z_executable {
    my($class) = @_;
    my $old_default = $class_defaults{ '7zip' };
    my $envsep = $^O =~ /MSWin/ ? ';' : ':';
    my $found;
    if( $ENV{PERL_ARCHIVE_SEVENZIP_BIN}) {
        $class_defaults{'7zip'} = $ENV{PERL_ARCHIVE_SEVENZIP_BIN};
        $found = $class->version || "7zip not found via environment '($ENV{PERL_ARCHIVE_SEVENZIP_BIN})'";
    } else {
        my @search;
        push @search, split /$envsep/, $ENV{PATH};
        if( $^O =~ /MSWin/i ) {
            push @search, map { "$_\\7-Zip" } grep {defined} ($ENV{'ProgramFiles'}, $ENV{'ProgramFiles(x86)'});
        };
        $found = $class->version;

        while( ! defined $found and @search) {
            my $dir = shift @search;
            if ($^O eq 'MSWin32') {
                next unless -e file("$dir", "7z.exe" );
            }
            $class_defaults{'7zip'} = "" . file("$dir", "7z" );
            $found = $class->version;
        };
    };

    if( ! $found) {
        $class_defaults{ '7zip' } = $old_default;
    };
    return defined $found ? $found : ()
}

=head2 C<< Archive::SevenZip->new >>

lib/Archive/SevenZip.pm  view on Meta::CPAN

            $src = "$target_dir/" . encode('UTF-8', $org);
        }
        rename $src => $extractedName
            or croak "Couldn't move '$src' ('$memberOrName') to '$extractedName': $!";
    };

    return AZ_OK;
};

=head2 C<< $ar->removeMember >>

  $ar->removeMember('test.txt');

Removes the member from the archive.

=cut

# strikingly similar to Archive::Zip API
sub removeMember {
    my( $self, $name, %_options ) = @_;

    my %options = (%$self, %_options);

    if( $^O =~ /MSWin/ ) {
        $name =~ s!/!\\!g;
    }

    my $cmd = $self->get_command(
        command     => "d",
        archivename => $options{ archivename },
        members     => [ $name ],
    );
    my $fh = $self->run($cmd, encoding => $options{ encoding } );
    $self->wait($fh, %options);

    return AZ_OK;
};

sub add_quotes {
    my $quote = shift;

    $quote ?
        map {
            defined $_ && /\s/ ? qq{"$_"} : $_
        } @_
    : @_
};

sub get_command {
    my( $self, %options )= @_;
    $options{ members } ||= [];
    $options{ archivename } = $self->{ archivename }
        unless defined $options{ archivename };
    if( ! exists $options{ fs_encoding }) {
        $options{ fs_encoding } = defined $self->{ fs_encoding } ? $self->{ fs_encoding } : $class_defaults{ fs_encoding };
    };
    if( ! defined $options{ default_options }) {
        $options{ default_options } = defined $self->{ default_options } ? $self->{ default_options } : $class_defaults{ default_options };
    };

    my @charset;
    if( defined $options{ fs_encoding }) {
        exists $sevenzip_charsetname{ $options{ fs_encoding }}
            or croak "Unknown filesystem encoding '$options{ fs_encoding }'";
        if( my $charset = $sevenzip_charsetname{ $options{ fs_encoding }}) {
            push @charset, "-scs" . $sevenzip_charsetname{ $options{ fs_encoding }};
        };
    };
    for(@{ $options{ members }}) {
        $_ = encode $options{ fs_encoding }, $_;
    };

    my $add_quote = $self->{system_needs_quotes};
    return [grep {defined $_}
        add_quotes($add_quote, $self->{ '7zip' }),
        @{ $options{ default_options }},
        $options{ command },
        @charset,
        add_quotes($add_quote, @{ $options{ options }} ),
        # "--",
        add_quotes($add_quote, $options{ archivename } ),
        add_quotes($add_quote, @{ $options{ members }} ),
    ];
}

sub run {
    my( $self, $cmd, %options )= @_;

    my $mode = '-|';
    if( defined $options{ stdin } || defined $options{ stdin_fh }) {
        $mode = '|-';
    };

    my $fh;
    warn "Opening [@$cmd]"
        if $options{ verbose } || $self->{verbose};

    if( $self->{verbose} ) {
        CORE::open( $fh, $mode, @$cmd)
            or croak "Couldn't launch [$mode @$cmd]: $!/$?";
    } else {
        CORE::open( my $fh_err, '>', File::Spec->devnull )
            or warn "Couldn't redirect child STDERR";
        my $errh = fileno $fh_err;
        my $fh_in = $options{ stdin_fh };
        # We accumulate zombie PIDs here, ah well.
        $SIG{'CHLD'} = 'IGNORE';
        my $pid = open3( $fh_in, my $fh_out, '>&' . $errh, @$cmd)
            or croak "Couldn't launch [$mode @$cmd]: $!/$?";
        if( $mode eq '|-' ) {
            $fh = $fh_in;
        } else {
            $fh = $fh_out
        };
    }
    if( $options{ encoding }) {
        binmode $fh, ":encoding($options{ encoding })";
    } elsif( $options{ binmode } ) {
        binmode $fh, $options{ binmode };
    };

    if( $options{ stdin }) {
        print {$fh} $options{ stdin };
        close $fh;

    } elsif( $options{ stdin_fh } ) {
        close $fh;

    } elsif( $options{ skip }) {
        for( 1..$options{ skip }) {
            # Read that many lines
            local $/ = "\n";
            scalar <$fh>;
        };
    };

    $fh;
}