Imported Upstream version 0.06
This commit is contained in:
commit
fd6c0eeda3
|
@ -0,0 +1,11 @@
|
|||
Makefile
|
||||
Makefile.old
|
||||
*.tar.gz
|
||||
*.bak
|
||||
pm_to_blib
|
||||
blib/
|
||||
Archive-SevenZip-*/
|
||||
Archive-SevenZip-*
|
||||
.releaserc
|
||||
cover_db
|
||||
MYMETA.*
|
|
@ -0,0 +1,24 @@
|
|||
0.06 20160411
|
||||
. Restore compatibility with Perl 5.6.x
|
||||
This means foregoing the defined-or operator, but as that one
|
||||
only came in with Perl 5.10, I'm removing the use
|
||||
|
||||
0.05 20160410
|
||||
. More test fixes by Alexandr Ciornii
|
||||
. No "undefined" warnings on non-Windows sytems
|
||||
|
||||
0.04 20160409
|
||||
. Switch tests to make indirect reliance on Archive::Zip optional
|
||||
. This time, test those changes using Test::Without::Module
|
||||
. Fix some documentation, add SYNOPSIS to Archive::SevenZip::API::ArchiveZip
|
||||
No code changes
|
||||
|
||||
0.03 20160407
|
||||
. Switch tests to make indirect reliance on Archive::Zip optional
|
||||
No code changes
|
||||
|
||||
0.02 20160404
|
||||
! Switch all IPC to IPC::Open3
|
||||
|
||||
0.01 20160403
|
||||
. Released on an unsuspecting world
|
|
@ -0,0 +1,47 @@
|
|||
.gitignore
|
||||
Changes
|
||||
lib/Archive/SevenZip.pm
|
||||
lib/Archive/SevenZip/API/ArchiveZip.pm
|
||||
lib/Archive/SevenZip/Entry.pm
|
||||
Makefile.PL
|
||||
MANIFEST This list of files
|
||||
MANIFEST.SKIP
|
||||
META.json
|
||||
META.yml
|
||||
t/01-identity.t
|
||||
t/02-add-scalar.t
|
||||
t/02_main.t
|
||||
t/05_tree.t
|
||||
t/20_bug_github11.t
|
||||
t/badjpeg/expected.jpg
|
||||
t/badjpeg/source.zip
|
||||
t/common.pm
|
||||
t/data/bad_github11.zip
|
||||
t/data/chmod.zip
|
||||
t/data/crypcomp.zip
|
||||
t/data/crypt.zip
|
||||
t/data/def.zip
|
||||
t/data/defstr.zip
|
||||
t/data/emptydef.zip
|
||||
t/data/emptydefstr.zip
|
||||
t/data/emptystore.zip
|
||||
t/data/emptystorestr.zip
|
||||
t/data/fred
|
||||
t/data/good_github11.zip
|
||||
t/data/jar.zip
|
||||
t/data/linux.zip
|
||||
t/data/mkzip.pl
|
||||
t/data/perl.zip
|
||||
t/data/store.zip
|
||||
t/data/storestr.zip
|
||||
t/data/streamed.zip
|
||||
t/data/winzip.zip
|
||||
t/data/zip64.zip
|
||||
xt/99-changes.t
|
||||
xt/99-compile.t
|
||||
xt/99-manifest.t
|
||||
xt/99-minimumversion.t
|
||||
xt/99-pod.t
|
||||
xt/99-todo.t
|
||||
xt/99-unix-text.t
|
||||
xt/99-versions.t
|
|
@ -0,0 +1,19 @@
|
|||
^\.git\/
|
||||
maint
|
||||
^tags$
|
||||
.last_cover_stats
|
||||
Makefile$
|
||||
^blib
|
||||
^pm_to_blib
|
||||
^.*.bak
|
||||
^.*.old
|
||||
^t.*sessions
|
||||
^cover_db
|
||||
^.*\.log
|
||||
^.*\.swp$
|
||||
^jar/
|
||||
^cpan/
|
||||
^MYMETA
|
||||
^.releaserc
|
||||
^Archive-SevenZip-.*/
|
||||
^Archive-SevenZip-.*.tar.gz$
|
|
@ -0,0 +1,31 @@
|
|||
{
|
||||
"abstract" : "Read/write 7z , zip , ISO9960 and other archives",
|
||||
"author" : [
|
||||
"Max Maischein <corion@cpan.org>"
|
||||
],
|
||||
"dynamic_config" : 1,
|
||||
"generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921",
|
||||
"license" : [
|
||||
"perl_5"
|
||||
],
|
||||
"meta-spec" : {
|
||||
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
|
||||
"version" : "2"
|
||||
},
|
||||
"name" : "Archive-SevenZip",
|
||||
"no_index" : {
|
||||
"directory" : [
|
||||
"t",
|
||||
"inc"
|
||||
]
|
||||
},
|
||||
"release_status" : "stable",
|
||||
"resources" : {
|
||||
"repository" : {
|
||||
"type" : "git",
|
||||
"url" : "git://github.com/Corion/archive-sevenzip.git",
|
||||
"web" : "https://github.com/Corion/archive-sevenzip"
|
||||
}
|
||||
},
|
||||
"version" : "0.06"
|
||||
}
|
|
@ -0,0 +1,19 @@
|
|||
---
|
||||
abstract: 'Read/write 7z , zip , ISO9960 and other archives'
|
||||
author:
|
||||
- 'Max Maischein <corion@cpan.org>'
|
||||
build_requires: {}
|
||||
dynamic_config: 1
|
||||
generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921'
|
||||
license: perl
|
||||
meta-spec:
|
||||
url: http://module-build.sourceforge.net/META-spec-v1.4.html
|
||||
version: 1.4
|
||||
name: Archive-SevenZip
|
||||
no_index:
|
||||
directory:
|
||||
- t
|
||||
- inc
|
||||
resources:
|
||||
repository: git://github.com/Corion/archive-sevenzip.git
|
||||
version: 0.06
|
|
@ -0,0 +1,115 @@
|
|||
# -*- mode: perl; c-basic-offset: 4; indent-tabs-mode: nil; -*-
|
||||
|
||||
use strict;
|
||||
use ExtUtils::MakeMaker qw(WriteMakefile);
|
||||
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
|
||||
# the contents of the Makefile that is written.
|
||||
|
||||
# Normalize version strings like 6.30_02 to 6.3002,
|
||||
# so that we can do numerical comparisons on it.
|
||||
my $eumm_version = $ExtUtils::MakeMaker::VERSION;
|
||||
$eumm_version =~ s/_//;
|
||||
|
||||
my $module = 'Archive::SevenZip';
|
||||
(my $main_file = "lib/$module.pm" ) =~ s!::!/!g;
|
||||
|
||||
# I should maybe use something like Shipwright...
|
||||
regen_README();
|
||||
#regen_EXAMPLES();
|
||||
|
||||
my @tests = map { glob $_ } 't/*.t', 't/*/*.t';
|
||||
|
||||
WriteMakefile1(
|
||||
NAME => $module,
|
||||
AUTHOR => q{Max Maischein <corion@cpan.org>},
|
||||
VERSION_FROM => $main_file,
|
||||
ABSTRACT_FROM => $main_file,
|
||||
META_MERGE => {
|
||||
"meta-spec" => { version => 2 },
|
||||
resources => {
|
||||
repository => {
|
||||
web => 'https://github.com/Corion/archive-sevenzip',
|
||||
url => 'git://github.com/Corion/archive-sevenzip.git',
|
||||
type => 'git',
|
||||
}
|
||||
},
|
||||
},
|
||||
|
||||
MIN_PERL_VERSION => '5.006',
|
||||
|
||||
($eumm_version >= 6.3001
|
||||
? ('LICENSE'=> 'perl')
|
||||
: ()),
|
||||
|
||||
PL_FILES => {},
|
||||
BUILD_REQUIRES => {
|
||||
'ExtUtils::MakeMaker' => 0,
|
||||
},
|
||||
|
||||
PREREQ_PM => {
|
||||
'Test::More' => 0,
|
||||
'File::Spec' => 0, # some tests do, at least
|
||||
'Exporter' => 5, # for 'import'
|
||||
|
||||
'File::Temp' => 0,
|
||||
'File::Copy' => 0,
|
||||
'IPC::Open3' => 0, # for talking to 7zip
|
||||
'Path::Class' => 0,
|
||||
'Encode' => 0,
|
||||
'File::Basename' => 0,
|
||||
'Time::Piece' => 0,
|
||||
},
|
||||
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
|
||||
clean => { FILES => 'Archive-SevenZip-*' },
|
||||
|
||||
test => { TESTS => join( ' ', @tests ) },
|
||||
);
|
||||
|
||||
1;
|
||||
|
||||
sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade.
|
||||
my %params=@_;
|
||||
my $eumm_version=$ExtUtils::MakeMaker::VERSION;
|
||||
$eumm_version=eval $eumm_version;
|
||||
die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
|
||||
die "License not specified" if not exists $params{LICENSE};
|
||||
if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
|
||||
#EUMM 6.5502 has problems with BUILD_REQUIRES
|
||||
$params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
|
||||
delete $params{BUILD_REQUIRES};
|
||||
}
|
||||
delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
|
||||
delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
|
||||
delete $params{META_MERGE} if $eumm_version < 6.46;
|
||||
delete $params{META_ADD} if $eumm_version < 6.46;
|
||||
delete $params{LICENSE} if $eumm_version < 6.31;
|
||||
delete $params{AUTHOR} if $] < 5.005;
|
||||
delete $params{ABSTRACT_FROM} if $] < 5.005;
|
||||
delete $params{BINARY_LOCATION} if $] < 5.005;
|
||||
|
||||
WriteMakefile(%params);
|
||||
}
|
||||
|
||||
sub regen_README {
|
||||
eval {
|
||||
require Pod::Readme;
|
||||
Pod::Readme->VERSION('1.0.2'); #0.11 may hang
|
||||
|
||||
my $parser = Pod::Readme->new();
|
||||
|
||||
# Read POD from Module.pm and write to README
|
||||
$parser->parse_from_file($_[0], 'README');
|
||||
};
|
||||
eval {
|
||||
require Pod::Markdown;
|
||||
|
||||
my $parser = Pod::Markdown->new();
|
||||
|
||||
# Read POD from Module.pm and write to README
|
||||
$parser->parse_from_file($_[0]);
|
||||
open my $fh, '>', 'README.mkdn'
|
||||
or die "Couldn't open 'README.mkdn': $!";
|
||||
print $fh $parser->as_markdown;
|
||||
};
|
||||
}
|
||||
|
|
@ -0,0 +1,726 @@
|
|||
package Archive::SevenZip;
|
||||
use strict;
|
||||
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
|
||||
|
||||
use vars qw(%sevenzip_charsetname %class_defaults $VERSION @EXPORT_OK %EXPORT_TAGS);
|
||||
$VERSION= '0.06';
|
||||
|
||||
# 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
|
||||
|
||||
@EXPORT_OK = (qw(AZ_OK COMPRESSION_STORED COMPRESSION_DEFLATED));
|
||||
%EXPORT_TAGS = (
|
||||
ERROR_CODES => [
|
||||
qw(
|
||||
AZ_OK
|
||||
)
|
||||
#AZ_STREAM_END
|
||||
#AZ_ERROR
|
||||
#AZ_FORMAT_ERROR
|
||||
#AZ_IO_ERROR
|
||||
],
|
||||
CONSTANTS => [
|
||||
qw(COMPRESSION_STORED COMPRESSION_DEFLATED)
|
||||
],
|
||||
);
|
||||
|
||||
%sevenzip_charsetname = (
|
||||
'UTF-8' => 'UTF-8',
|
||||
'Latin-1' => 'WIN',
|
||||
'ISO-8859-1' => 'WIN',
|
||||
'' => 'DOS', # dunno what the appropriate name would be
|
||||
);
|
||||
|
||||
if( $^O !~ /MSWin/ ) {
|
||||
# Wipe all filesystem encodings because my Debian 7z 9.20 doesn't understand them
|
||||
$sevenzip_charsetname{ $_ } = ''
|
||||
for keys %sevenzip_charsetname;
|
||||
};
|
||||
|
||||
%class_defaults = (
|
||||
'7zip' => '7z',
|
||||
fs_encoding => 'UTF-8',
|
||||
default_options => [ "-y", "-bd" ],
|
||||
type => 'zip',
|
||||
);
|
||||
|
||||
=head2 C<< Archive::SevenZip->find_7z_executable >>
|
||||
|
||||
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.
|
||||
|
||||
=cut
|
||||
|
||||
sub find_7z_executable {
|
||||
my($class) = @_;
|
||||
my $old_default = $class_defaults{ '7zip' };
|
||||
my $envsep = $^O =~ /MSWin/ ? ';' : ':';
|
||||
my @search = split /$envsep/, $ENV{PATH};
|
||||
if( $^O =~ /MSWin/i ) {
|
||||
push @search, map { "$_\\7-Zip" } grep {defined} ($ENV{'ProgramFiles'}, $ENV{'ProgramFiles(x86)'});
|
||||
};
|
||||
my $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 >>
|
||||
|
||||
my $ar = Archive::SevenZip->new( $archivename );
|
||||
|
||||
my $ar = Archive::SevenZip->new(
|
||||
archivename => $archivename,
|
||||
find => 1,
|
||||
);
|
||||
|
||||
Creates a new class instance.
|
||||
|
||||
C<find> - will try to find the executable using C<< ->find_7z_executable >>
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my( $class, %options);
|
||||
if( @_ == 2 ) {
|
||||
($class, $options{ archivename }) = @_;
|
||||
} else {
|
||||
($class, %options) = @_;
|
||||
};
|
||||
|
||||
if( $options{ find }) {
|
||||
$class->find_7z_executable();
|
||||
};
|
||||
|
||||
for( keys %class_defaults ) {
|
||||
$options{ $_ } = $class_defaults{ $_ }
|
||||
unless defined $options{ $_ };
|
||||
};
|
||||
|
||||
bless \%options => $class
|
||||
}
|
||||
|
||||
sub version {
|
||||
my( $self_or_class, %options) = @_;
|
||||
for( keys %class_defaults ) {
|
||||
$options{ $_ } = $class_defaults{ $_ }
|
||||
unless defined $options{ $_ };
|
||||
};
|
||||
my $self = ref $self_or_class ? $self_or_class : $self_or_class->new( %options );
|
||||
|
||||
my $cmd = $self->get_command(
|
||||
command => '',
|
||||
archivename => undef,
|
||||
options => [], # on Debian, 7z doesn't like any options...
|
||||
fs_encoding => undef, # on Debian, 7z doesn't like any options...
|
||||
default_options => [], # on Debian, 7z doesn't like any options...
|
||||
);
|
||||
my $fh = eval { $self->run($cmd, binmode => ':raw') };
|
||||
|
||||
if( ! $@ ) {
|
||||
local $/ = "\n";
|
||||
my @output = <$fh>;
|
||||
if( @output >= 3) {
|
||||
$output[1] =~ /^7-Zip\s+.*?(\d+\.\d+)\s+(?:\s*:\s*)?Copyright/
|
||||
or return undef;
|
||||
return $1;
|
||||
} else {
|
||||
return undef
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head2 C<< $ar->open >>
|
||||
|
||||
my @entries = $ar->open;
|
||||
for my $entry (@entries) {
|
||||
print $entry->name, "\n";
|
||||
};
|
||||
|
||||
Lists the entries in the archive. A fresh archive which does not
|
||||
exist on disk yet has no entries. The returned entries
|
||||
are L<Archive::SevenZip::Entry> instances.
|
||||
|
||||
This method will one day move to the Path::Class-compatibility
|
||||
API.
|
||||
|
||||
=cut
|
||||
# Iterate over the entries in the archive
|
||||
# Path::Class API
|
||||
sub open {
|
||||
my( $self )= @_;
|
||||
my @contents = $self->list();
|
||||
}
|
||||
|
||||
=head2 C<< $ar->memberNamed >>
|
||||
|
||||
my $entry = $ar->memberNamed('hello_world.txt');
|
||||
print $entry->fileName, "\n";
|
||||
|
||||
The path separator must be a forward slash ("/")
|
||||
|
||||
This method will one day move to the Archive::Zip-compatibility
|
||||
API.
|
||||
|
||||
=cut
|
||||
|
||||
# Archive::Zip API
|
||||
sub memberNamed {
|
||||
my( $self, $name, %options )= @_;
|
||||
|
||||
my( $entry ) = grep { $_->fileName eq $name } $self->members( %options );
|
||||
$entry
|
||||
}
|
||||
|
||||
# Archive::Zip API
|
||||
sub list {
|
||||
my( $self, %options )= @_;
|
||||
|
||||
if( ! grep { defined $_ } $options{archivename}, $self->{archivename}) {
|
||||
# We are an archive that does not exist on disk yet
|
||||
return
|
||||
};
|
||||
my $cmd = $self->get_command( command => "l", options => ["-slt"], %options );
|
||||
|
||||
my $fh = $self->run($cmd, encoding => $options{ fs_encoding } );
|
||||
my @output = <$fh>;
|
||||
my %results = (
|
||||
header => [],
|
||||
archive => [],
|
||||
);
|
||||
|
||||
# Get/skip header
|
||||
while( @output and $output[0] !~ /^--\s*$/ ) {
|
||||
my $line = shift @output;
|
||||
$line =~ s!\s+$!!;
|
||||
push @{ $results{ header }}, $line;
|
||||
};
|
||||
|
||||
# Get/skip archive information
|
||||
while( @output and $output[0] !~ /^----------\s*$/ ) {
|
||||
my $line = shift @output;
|
||||
$line =~ s!\s+$!!;
|
||||
push @{ $results{ archive }}, $line;
|
||||
};
|
||||
|
||||
if( $output[0] =~ /^----------\s*$/ ) {
|
||||
shift @output;
|
||||
} else {
|
||||
warn "Unexpected line in 7zip output, hope that's OK: [$output[0]]";
|
||||
};
|
||||
|
||||
my @members;
|
||||
|
||||
# Split entries
|
||||
my %entry_info;
|
||||
while( @output ) {
|
||||
my $line = shift @output;
|
||||
if( $line =~ /^([\w ]+) =(?: (.*?)|)\s*$/ ) {
|
||||
$entry_info{ $1 } = $2;
|
||||
} elsif($line =~ /^\s*$/) {
|
||||
push @members, Archive::SevenZip::Entry->new(
|
||||
%entry_info,
|
||||
_Container => $self,
|
||||
);
|
||||
%entry_info = ();
|
||||
} else {
|
||||
croak "Unknown file entry [$line]";
|
||||
};
|
||||
};
|
||||
|
||||
return @members
|
||||
}
|
||||
{ no warnings 'once';
|
||||
*members = \&list;
|
||||
}
|
||||
|
||||
=head2 C<< $ar->openMemberFH >>
|
||||
|
||||
my $fh = $ar->openMemberFH('test.txt');
|
||||
while( <$fh> ) {
|
||||
print "test.txt: $_";
|
||||
};
|
||||
|
||||
Reads the uncompressed content of the member from the archive.
|
||||
|
||||
This method will one day move to the Archive::Zip-compatibility
|
||||
API.
|
||||
|
||||
=cut
|
||||
|
||||
sub openMemberFH {
|
||||
my( $self, %options );
|
||||
if( @_ == 2 ) {
|
||||
($self,$options{ membername })= @_;
|
||||
} else {
|
||||
($self,%options) = @_;
|
||||
};
|
||||
defined $options{ membername } or croak "Need member name to extract";
|
||||
|
||||
my $cmd = $self->get_command( command => "e", options => ["-so"], members => [$options{membername}] );
|
||||
my $fh = $self->run($cmd, encoding => $options{ encoding }, binmode => $options{ binmode });
|
||||
return $fh
|
||||
}
|
||||
|
||||
sub content {
|
||||
my( $self, %options ) = @_;
|
||||
my $fh = $self->openMemberFH( %options );
|
||||
local $/;
|
||||
<$fh>
|
||||
}
|
||||
=head2 C<< $ar->extractMember >>
|
||||
|
||||
$ar->extractMember('test.txt' => 'extracted_test.txt');
|
||||
|
||||
Extracts the uncompressed content of the member from the archive.
|
||||
|
||||
This method will one day move to the Archive::Zip-compatibility
|
||||
API.
|
||||
|
||||
=cut
|
||||
|
||||
# Archive::Zip API
|
||||
sub extractMember {
|
||||
my( $self, $memberOrName, $extractedName, %_options ) = @_;
|
||||
$extractedName = $memberOrName
|
||||
unless defined $extractedName;
|
||||
|
||||
my %options = (%$self, %_options);
|
||||
|
||||
my $target_dir = dirname $extractedName;
|
||||
my $target_name = basename $extractedName;
|
||||
my $cmd = $self->get_command(
|
||||
command => "e",
|
||||
archivename => $options{ archivename },
|
||||
members => [ $memberOrName ],
|
||||
options => [ "-o$target_dir" ],
|
||||
);
|
||||
my $fh = $self->run($cmd, encoding => $options{ encoding });
|
||||
|
||||
while( <$fh>) {
|
||||
warn $_ if $options{ verbose };
|
||||
};
|
||||
if( basename $memberOrName ne $target_name ) {
|
||||
rename "$target_dir/" . basename($memberOrName) => $extractedName
|
||||
or croak "Couldn't move '$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 {
|
||||
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 }, $_;
|
||||
};
|
||||
|
||||
# Now quote what needs to be quoted
|
||||
for( @{ $options{ options }}, @{ $options{ members }}, $options{ archivename }, "$self->{ '7zip' }") {
|
||||
};
|
||||
|
||||
return [grep {defined $_}
|
||||
add_quotes($self->{ '7zip' }),
|
||||
@{ $options{ default_options }},
|
||||
$options{ command },
|
||||
@charset,
|
||||
add_quotes( @{ $options{ options }} ),
|
||||
add_quotes( $options{ archivename } ),
|
||||
add_quotes( @{ $options{ members }} ),
|
||||
];
|
||||
}
|
||||
|
||||
sub run {
|
||||
my( $self, $cmd, %options )= @_;
|
||||
|
||||
my $mode = '-|';
|
||||
if( defined $options{ stdin }) {
|
||||
$mode = '|-';
|
||||
};
|
||||
|
||||
my $fh;
|
||||
warn "Opening [@$cmd]"
|
||||
if $options{ 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;
|
||||
# We accumulate zombie PIDs here, ah well.
|
||||
my $pid = open3( my $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{ skip }) {
|
||||
for( 1..$options{ skip }) {
|
||||
# Read that many lines
|
||||
local $/ = "\n";
|
||||
scalar <$fh>;
|
||||
};
|
||||
};
|
||||
|
||||
$fh;
|
||||
}
|
||||
|
||||
sub archive_or_temp {
|
||||
my( $self ) = @_;
|
||||
if( ! defined $self->{archivename} ) {
|
||||
$self->{is_tempfile} = 1;
|
||||
(my( $fh ),$self->{archivename}) = tempfile( SUFFIX => ".$self->{type}" );
|
||||
close $fh;
|
||||
unlink $self->{archivename};
|
||||
};
|
||||
$self->{archivename}
|
||||
};
|
||||
|
||||
sub wait {
|
||||
my( $self, $fh, %options ) = @_;
|
||||
while( <$fh>) {
|
||||
warn $_ if ($options{ verbose } || $self->{verbose})
|
||||
};
|
||||
}
|
||||
|
||||
=head2 C<< $ar->add_scalar >>
|
||||
|
||||
$ar->add_scalar( "Some name.txt", "This is the content" );
|
||||
|
||||
Adds a scalar as an archive member.
|
||||
|
||||
Unfortunately, 7zip doesn't reliably read archive members from STDIN,
|
||||
so the scalar will be written to a tempfile, added to the archive and then
|
||||
renamed in the archive.
|
||||
|
||||
This requires 7zip version 9.30+
|
||||
|
||||
=cut
|
||||
|
||||
sub add_scalar {
|
||||
my( $self, $name, $scalar )= @_;
|
||||
|
||||
# 7zip doesn't really support reading archive members from STDIN :-(
|
||||
my($fh, $tempname) = tempfile;
|
||||
binmode $fh, ':raw';
|
||||
print {$fh} $scalar;
|
||||
close $fh;
|
||||
|
||||
# Only supports 7z archive type?!
|
||||
# 7zip will magically append .7z to the filename :-(
|
||||
my $cmd = $self->get_command(
|
||||
command => 'a',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => [$tempname],
|
||||
#options => ],
|
||||
);
|
||||
$fh = $self->run( $cmd );
|
||||
$self->wait($fh);
|
||||
|
||||
unlink $tempname
|
||||
or warn "Couldn't unlink '$tempname': $!";
|
||||
|
||||
# Hopefully your version of 7zip can rename members (9.30+):
|
||||
$cmd = $self->get_command(
|
||||
command => 'rn',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => [basename($tempname), $name],
|
||||
#options => ],
|
||||
);
|
||||
$fh = $self->run( $cmd );
|
||||
$self->wait($fh);
|
||||
|
||||
# Once 7zip supports reading from stdin, this will work again:
|
||||
#my $fh = $self->run( $cmd,
|
||||
# binmode => ':raw',
|
||||
# stdin => $scalar,
|
||||
# verbose => 1,
|
||||
#);
|
||||
};
|
||||
|
||||
=head2 C<< $ar->add_directory >>
|
||||
|
||||
$ar->add_directory( "real_etc", "etc" );
|
||||
|
||||
Adds an empty directory
|
||||
|
||||
This currently ignores the directory date and time if the directory
|
||||
exists
|
||||
|
||||
=cut
|
||||
|
||||
sub add_directory {
|
||||
my( $self, $localname, $target )= @_;
|
||||
|
||||
$target ||= $localname;
|
||||
|
||||
# Create an empty directory, add it to the archive,
|
||||
# then rename that temp name to the wanted name:
|
||||
my $tempname = tempdir;
|
||||
|
||||
my $cmd = $self->get_command(
|
||||
command => 'a',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => [$tempname],
|
||||
options => ['-r0'],
|
||||
);
|
||||
my $fh = $self->run( $cmd );
|
||||
$self->wait($fh);
|
||||
|
||||
# Hopefully your version of 7zip can rename members (9.30+):
|
||||
$cmd = $self->get_command(
|
||||
command => 'rn',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => [basename($tempname), $target],
|
||||
);
|
||||
$fh = $self->run( $cmd );
|
||||
$self->wait($fh);
|
||||
|
||||
# Once 7zip supports reading from stdin, this will work again:
|
||||
#my $fh = $self->run( $cmd,
|
||||
# binmode => ':raw',
|
||||
# stdin => $scalar,
|
||||
# verbose => 1,
|
||||
#);
|
||||
};
|
||||
|
||||
sub add {
|
||||
my( $self, %options )= @_;
|
||||
|
||||
my @items = @{ delete $options{ items } || [] };
|
||||
|
||||
# Split up the list into one batch for the listfiles
|
||||
# and the list of files we need to rename
|
||||
|
||||
my @filelist;
|
||||
for my $item (@items) {
|
||||
if( ! ref $item ) {
|
||||
$item = [ $item, $item ];
|
||||
};
|
||||
my( $name, $storedName ) = @$item;
|
||||
|
||||
if( $name ne $storedName ) {
|
||||
# We need to pipe to 7zip from stdin (no, we don't, we can rename afterwards)
|
||||
# This still means we might overwrite an already existing file in the archive...
|
||||
# But 7-zip seems to not like duplicate filenames anyway in "@"-listfiles...
|
||||
my $cmd = $self->get_command(
|
||||
command => 'a',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => [$name],
|
||||
#options => ],
|
||||
);
|
||||
my $fh = $self->run( $cmd );
|
||||
$self->wait($fh, %options );
|
||||
$cmd = $self->get_command(
|
||||
command => 'rn',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => [$name, $storedName],
|
||||
#options => ],
|
||||
);
|
||||
$fh = $self->run( $cmd );
|
||||
$self->wait($fh, %options );
|
||||
|
||||
} else {
|
||||
# 7zip can read the file from disk
|
||||
# Write the name to a tempfile to be read by 7zip for batching
|
||||
push @filelist, $name;
|
||||
};
|
||||
};
|
||||
|
||||
if( @filelist ) {
|
||||
my( $fh, $name) = tempfile;
|
||||
binmode $fh, ':raw';
|
||||
print {$fh} join "\r\n", @filelist;
|
||||
close $fh;
|
||||
|
||||
my @options;
|
||||
if( $options{ recursive }) {
|
||||
push @options, '-r';
|
||||
};
|
||||
|
||||
my $cmd = $self->get_command(
|
||||
command => 'a',
|
||||
archivename => $self->archive_or_temp,
|
||||
members => ['@'.$name],
|
||||
options => \@options
|
||||
);
|
||||
$fh = $self->run( $cmd );
|
||||
$self->wait($fh, %options);
|
||||
};
|
||||
};
|
||||
|
||||
sub archiveZipApi {
|
||||
my( $class, %options ) = @_;
|
||||
require Archive::SevenZip::API::ArchiveZip;
|
||||
Archive::SevenZip::API::ArchiveZip->new( %options )
|
||||
}
|
||||
|
||||
package Path::Class::Archive::Handle;
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Path::Class::Archive - treat archives as directories
|
||||
|
||||
=cut
|
||||
|
||||
package Path::Class::Archive;
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 CAUTION
|
||||
|
||||
This module tries to mimic the API of L<Archive::Zip> in some cases
|
||||
and in other cases, the API of L<Path::Class>. It is also a very rough
|
||||
draft that just happens to be doing what I need, mostly extracting
|
||||
files.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Unpack> - also supports unpacking from 7z archives
|
||||
|
||||
L<Compress::unLZMA> - uncompressor for the LZMA compression method used by 7z
|
||||
|
||||
=head1 REPOSITORY
|
||||
|
||||
The public repository of this module is
|
||||
L<http://github.com/Corion/archive-sevenzip>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
The public support forum of this module is
|
||||
L<https://perlmonks.org/>.
|
||||
|
||||
=head1 BUG TRACKER
|
||||
|
||||
Please report bugs in this module via the RT CPAN bug queue at
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Archive-SevenZip>
|
||||
or via mail to L<archive-sevenzip-Bugs@rt.cpan.org>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Max Maischein C<corion@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT (c)
|
||||
|
||||
Copyright 2015-2016 by Max Maischein C<corion@cpan.org>.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is released under the same terms as Perl itself.
|
||||
|
||||
=cut
|
|
@ -0,0 +1,244 @@
|
|||
package Archive::SevenZip::API::ArchiveZip;
|
||||
use strict;
|
||||
use Carp qw(croak);
|
||||
use Encode qw( decode encode );
|
||||
use File::Basename qw(dirname basename);
|
||||
use File::Copy;
|
||||
use Archive::SevenZip 'AZ_OK';
|
||||
|
||||
use vars qw($VERSION);
|
||||
$VERSION= '0.06';
|
||||
|
||||
sub new {
|
||||
my( $class, %options )= @_;
|
||||
$options{ sevenZip } = Archive::SevenZip->new();
|
||||
bless \%options => $class;
|
||||
};
|
||||
|
||||
sub sevenZip { $_[0]->{sevenZip} }
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Archive::SevenZip::API::ArchiveZip - Archive::Zip compatibility API
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $ar = Archive::SevenZip->archiveZipApi(
|
||||
find => 1,
|
||||
archivename => $archivename,
|
||||
verbose => $verbose,
|
||||
);
|
||||
|
||||
This module implements just enough of the L<Archive::Zip>
|
||||
API to pass some of the Archive::Zip test files. Ideally you can
|
||||
use this API to enable a script that uses Archive::Zip
|
||||
to also read other archive files supported by 7z.
|
||||
|
||||
=cut
|
||||
|
||||
sub writeToFileNamed {
|
||||
my( $self, $targetName )= @_;
|
||||
copy( $self->sevenZip->{archivename}, $targetName );
|
||||
return AZ_OK;
|
||||
}
|
||||
|
||||
sub addFileOrDirectory {
|
||||
my($self, $name, $newName, $compressionLevel) = @_;
|
||||
$newName = $name
|
||||
unless defined $newName;
|
||||
$self->sevenZip->add(
|
||||
items => [ [$name, $newName] ],
|
||||
compression => $compressionLevel
|
||||
);
|
||||
}
|
||||
|
||||
sub addString {
|
||||
my( $self, $content, $name, %options ) = @_;
|
||||
$self->sevenZip->add_scalar($name => $content);
|
||||
$self->memberNamed($name, %options);
|
||||
}
|
||||
|
||||
sub addDirectory {
|
||||
# Create just a directory name
|
||||
my( $self, $name, $target, %options ) = @_;
|
||||
$target ||= $name;
|
||||
|
||||
if( ref $name ) {
|
||||
croak "Hashref API not supported, sorry";
|
||||
};
|
||||
|
||||
$self->sevenZip->add_directory($name, $target, %options);
|
||||
$self->memberNamed($target, %options);
|
||||
}
|
||||
|
||||
sub members {
|
||||
my( $self ) = @_;
|
||||
$self->sevenZip->members;
|
||||
}
|
||||
|
||||
sub memberNames {
|
||||
my( $self ) = @_;
|
||||
map { $_->fileName } $self->sevenZip->members;
|
||||
}
|
||||
|
||||
sub membersMatching {
|
||||
my( $self, $re, %options ) = @_;
|
||||
grep { $_->fileName =~ /$re/ } $self->sevenZip->members;
|
||||
}
|
||||
|
||||
=head2 C<< $ar->numberOfMembers >>
|
||||
|
||||
my $count = $az->numberOfMembers();
|
||||
|
||||
=cut
|
||||
|
||||
sub numberOfMembers {
|
||||
my( $self, %options ) = @_;
|
||||
my @m = $self->members( %options );
|
||||
0+@m
|
||||
}
|
||||
|
||||
=head2 C<< $az->memberNamed >>
|
||||
|
||||
my $entry = $az->memberNamed('hello_world.txt');
|
||||
print $entry->fileName, "\n";
|
||||
|
||||
=cut
|
||||
|
||||
# Archive::Zip API
|
||||
sub memberNamed {
|
||||
my( $self, $name, %options )= @_;
|
||||
$self->sevenZip->memberNamed($name, %options );
|
||||
}
|
||||
|
||||
sub extractMember {
|
||||
my( $self, $name, $target, %options ) = @_;
|
||||
if( ref $name and $name->can('fileName')) {
|
||||
$name = $name->fileName;
|
||||
};
|
||||
$self->sevenZip->extractMember( $name, $target, %options );
|
||||
}
|
||||
|
||||
sub removeMember {
|
||||
my( $self, $name, $target, %options ) = @_;
|
||||
# Just for the result:
|
||||
my $res = ref $name ? $name : $self->memberNamed( $name );
|
||||
|
||||
if( ref $name and $name->can('fileName')) {
|
||||
$name = $name->fileName;
|
||||
};
|
||||
$self->sevenZip->removeMember( $name, %options );
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
=head2 C<< $ar->replaceMember >>
|
||||
|
||||
$ar->replaceMember('backup.txt', 'new-backup.txt');
|
||||
|
||||
Replaces the member in the archive. This is just delete then add.
|
||||
|
||||
I clearly don't understand the utility of this method. It clearly
|
||||
does not update the content of one file with the content of another
|
||||
file, as the name of the new file can be different.
|
||||
|
||||
=cut
|
||||
|
||||
# strikingly similar to Archive::Zip API
|
||||
sub replaceMember {
|
||||
my( $self, $name, $replacement, %_options ) = @_;
|
||||
|
||||
my %options = (%$self, %_options);
|
||||
|
||||
if( $^O =~ /MSWin/ ) {
|
||||
$name =~ s!/!\\!g;
|
||||
}
|
||||
|
||||
my $res = $self->removeMember( $name );
|
||||
$self->add( $replacement );
|
||||
|
||||
$res
|
||||
};
|
||||
|
||||
|
||||
sub addFile {
|
||||
my( $self, $name, $target, %options ) = @_;
|
||||
if( ref $name and $name->can('fileName')) {
|
||||
$name = $name->fileName;
|
||||
};
|
||||
$target ||= $name;
|
||||
$self->sevenZip->add( items => [[ $name, $target ]], %options );
|
||||
return $self->memberNamed($target, %options);
|
||||
}
|
||||
|
||||
sub addMember {
|
||||
my( $self, $name, $target, %options ) = @_;
|
||||
if( ref $name and $name->can('fileName')) {
|
||||
$name = $name->fileName;
|
||||
};
|
||||
$target ||= $name;
|
||||
$self->sevenZip->add( items => [[ $name, $target ]], %options );
|
||||
return $self->memberNamed($target, %options);
|
||||
}
|
||||
{ no warnings 'once';
|
||||
*add = \&addMember;
|
||||
}
|
||||
|
||||
sub addTree {
|
||||
my( $self, $sourceDir, $target, $predicate, %options ) = @_;
|
||||
|
||||
croak "Predicates are not supported, sorry"
|
||||
if $predicate;
|
||||
|
||||
$target ||= $sourceDir;
|
||||
croak "Different target for ->addTree not supported, sorry"
|
||||
if $target ne $sourceDir;
|
||||
|
||||
$self->sevenZip->add( items => [[ $sourceDir, $target ]], recursive => 1, %options );
|
||||
return $self->memberNamed($target, %options);
|
||||
}
|
||||
*add = \&addMember;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 CAUTION
|
||||
|
||||
This module tries to mimic the API of L<Archive::Zip>.
|
||||
|
||||
=head2 Differences between Archive::Zip and Archive::SevenZip
|
||||
|
||||
=head3 7-Zip does not guarantee the order of entries within an archive
|
||||
|
||||
The Archive::Zip test suite assumes that items added later to an
|
||||
archive will appear later in the directory listing. 7-zip makes no
|
||||
such guarantee.
|
||||
|
||||
=head1 REPOSITORY
|
||||
|
||||
The public repository of this module is
|
||||
L<http://github.com/Corion/archive-sevenzip>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
The public support forum of this module is
|
||||
L<https://perlmonks.org/>.
|
||||
|
||||
=head1 BUG TRACKER
|
||||
|
||||
Please report bugs in this module via the RT CPAN bug queue at
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Archive-SevenZip>
|
||||
or via mail to L<archive-sevenzip-Bugs@rt.cpan.org>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Max Maischein C<corion@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT (c)
|
||||
|
||||
Copyright 2015-2016 by Max Maischein C<corion@cpan.org>.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is released under the same terms as Perl itself.
|
||||
|
||||
=cut
|
|
@ -0,0 +1,138 @@
|
|||
package Archive::SevenZip::Entry;
|
||||
use strict;
|
||||
|
||||
use Time::Piece; # for strptime
|
||||
use File::Basename ();
|
||||
use Path::Class ();
|
||||
|
||||
use vars qw($VERSION);
|
||||
$VERSION= '0.06';
|
||||
|
||||
sub new {
|
||||
my( $class, %options) = @_;
|
||||
|
||||
bless \%options => $class
|
||||
}
|
||||
|
||||
sub archive {
|
||||
$_[0]->{_Container}
|
||||
}
|
||||
|
||||
sub fileName {
|
||||
my( $self ) = @_;
|
||||
|
||||
my $res = $self->{Path};
|
||||
|
||||
# Normalize to unixy path names
|
||||
$res =~ s!\\!/!g;
|
||||
|
||||
# If we're a directory, append the slash:
|
||||
if( $self->{Folder} eq '+') {
|
||||
$res .= '/';
|
||||
};
|
||||
|
||||
$res
|
||||
}
|
||||
|
||||
# Class::Path API
|
||||
sub basename {
|
||||
Path::Class::file( $_[0]->{Path} )->basename
|
||||
}
|
||||
|
||||
sub components {
|
||||
my $cp = file( $_[0]->{Path} );
|
||||
$cp->components()
|
||||
}
|
||||
|
||||
sub lastModFileDateTime {
|
||||
0
|
||||
}
|
||||
|
||||
sub crc32 {
|
||||
hex( $_[0]->{CRC} );
|
||||
}
|
||||
|
||||
sub crc32String {
|
||||
lc $_[0]->{CRC};
|
||||
}
|
||||
|
||||
sub desiredCompressionMethod {
|
||||
$_[0]->{Method}
|
||||
}
|
||||
|
||||
sub uncompressedSize {
|
||||
$_[0]->{Size}
|
||||
}
|
||||
|
||||
sub dir {
|
||||
# We need to return the appropriate class here
|
||||
# so that further calls to (like) dir->list
|
||||
# still work properly
|
||||
die "->dir Not implemented";
|
||||
}
|
||||
|
||||
sub open {
|
||||
my( $self, $mode, $permissions )= @_;
|
||||
$self->archive->openMemberFH( membername => $self->fileName, binmode => $mode );
|
||||
}
|
||||
{ no warnings 'once';
|
||||
*fh = \&open; # Archive::Zip API
|
||||
}
|
||||
|
||||
# Path::Class API
|
||||
sub slurp {
|
||||
my( $self, %options )= @_;
|
||||
my $fh = $self->archive->openMemberFH( membername => $self->fileName, binmode => $options{ iomode } );
|
||||
local $/;
|
||||
<$fh>
|
||||
}
|
||||
|
||||
# Archive::Zip API
|
||||
#externalFileName()
|
||||
|
||||
# Archive::Zip API
|
||||
#fileName()
|
||||
|
||||
# Archive::Zip API
|
||||
#lastModFileDateTime()
|
||||
|
||||
# Archive::Zip API
|
||||
#lastModTime()
|
||||
|
||||
# Archive::Zip API
|
||||
sub extractToFileNamed {
|
||||
my($self, $target) = @_;
|
||||
$self->archive->extractMember( $self->fileName, $target );
|
||||
};
|
||||
|
||||
1;
|
||||
|
||||
=head1 REPOSITORY
|
||||
|
||||
The public repository of this module is
|
||||
L<http://github.com/Corion/archive-sevenzip>.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
The public support forum of this module is
|
||||
L<https://perlmonks.org/>.
|
||||
|
||||
=head1 BUG TRACKER
|
||||
|
||||
Please report bugs in this module via the RT CPAN bug queue at
|
||||
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Archive-SevenZip>
|
||||
or via mail to L<archive-sevenzip-Bugs@rt.cpan.org>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Max Maischein C<corion@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT (c)
|
||||
|
||||
Copyright 2015-2016 by Max Maischein C<corion@cpan.org>.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is released under the same terms as Perl itself.
|
||||
|
||||
=cut
|
|
@ -0,0 +1,57 @@
|
|||
#!perl -w
|
||||
use strict;
|
||||
use Archive::SevenZip;
|
||||
use File::Basename;
|
||||
use Test::More tests => 2;
|
||||
use File::Temp 'tempfile';
|
||||
|
||||
my $version = Archive::SevenZip->find_7z_executable();
|
||||
if( ! $version ) {
|
||||
SKIP: { skip "7z binary not found (not installed?)", 2; }
|
||||
exit;
|
||||
};
|
||||
diag "7-zip version $version";
|
||||
|
||||
my $base = dirname($0) . '/data';
|
||||
my $archivename = "$base/def.zip";
|
||||
my $ar = Archive::SevenZip->new(
|
||||
archivename => $archivename,
|
||||
);
|
||||
|
||||
# Check that extraction to scalar and extraction to file
|
||||
# result in the same output
|
||||
|
||||
sub slurp {
|
||||
my( $fh ) = @_;
|
||||
binmode $fh;
|
||||
local $/;
|
||||
<$fh>
|
||||
};
|
||||
|
||||
my $originalname = "$base/fred";
|
||||
open my $fh, '<', $originalname
|
||||
or die "Couldn't read '$originalname': $!";
|
||||
my $original= slurp($fh);
|
||||
|
||||
sub data_matches_ok {
|
||||
my( $memory, $name) = @_;
|
||||
if( length($memory) == -s $originalname) {
|
||||
cmp_ok $memory, 'eq', $original, "extracted data matches ($name)";
|
||||
} else {
|
||||
fail "extracted data matches ($name)";
|
||||
diag "Got [$memory]";
|
||||
diag "expected [$original]";
|
||||
};
|
||||
}
|
||||
|
||||
my $memory = slurp( $ar->openMemberFH("fred"));
|
||||
data_matches_ok( $memory, "Memory extraction" );
|
||||
|
||||
( $fh, my $tempname)= tempfile();
|
||||
close $fh;
|
||||
$ar->extractMember("fred",$tempname);
|
||||
open $fh, '<', $tempname
|
||||
or die "Couldn't read '$tempname': $!";
|
||||
my $disk = slurp($fh);
|
||||
data_matches_ok( $disk, "Direct disk extraction" );
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
#!perl -w
|
||||
use strict;
|
||||
use Archive::SevenZip;
|
||||
use File::Basename;
|
||||
use Test::More tests => 2;
|
||||
use File::Temp 'tempfile';
|
||||
|
||||
my $version = Archive::SevenZip->find_7z_executable();
|
||||
if( ! $version ) {
|
||||
SKIP: { skip "7z binary not found (not installed?)", 2; }
|
||||
exit;
|
||||
};
|
||||
diag "7-zip version $version";
|
||||
if( $version <= 9.20) {
|
||||
SKIP: {
|
||||
skip "7z version $version does not support renaming", 2;
|
||||
}
|
||||
exit
|
||||
};
|
||||
|
||||
my $base = dirname($0) . '/data';
|
||||
my $ar = Archive::SevenZip->new(
|
||||
#archivename => $archivename,
|
||||
#type => '7z',
|
||||
);
|
||||
|
||||
#(my $tempname, undef) = tempfile;
|
||||
|
||||
my $content = "This is\x{0d}\x{0a}the content";
|
||||
$ar->add_scalar('some-member.txt',$content);
|
||||
#$ar->writeToFileNamed($tempname);
|
||||
|
||||
my @contents = map { $_->fileName } $ar->list();
|
||||
is_deeply \@contents, ["some-member.txt"], "Contents of created archive are OK";
|
||||
|
||||
my $written = $ar->content( membername => 'some-member.txt', binmode => ':raw');
|
||||
is $written, $content, "Reading back the same data as we wrote";
|
||||
|
|
@ -0,0 +1,381 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# Main testing for Archive::Zip
|
||||
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
$^W = 1;
|
||||
}
|
||||
|
||||
use Archive::SevenZip qw( :ERROR_CODES :CONSTANTS );
|
||||
use FileHandle;
|
||||
use File::Path;
|
||||
use File::Spec;
|
||||
|
||||
use Test::More;
|
||||
|
||||
use vars qw($testZipDoesntWork $status);
|
||||
|
||||
BEGIN {
|
||||
if( ! eval {
|
||||
require t::common;
|
||||
t::common->import;
|
||||
1
|
||||
}) {
|
||||
plan skip_all => "Archive::Zip not installed, skipping compatibility tests", 83;
|
||||
exit;
|
||||
} else {
|
||||
plan tests => 83;
|
||||
}
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Testing Utility Functions
|
||||
|
||||
#--------- check CRC
|
||||
is(TESTSTRINGCRC(), 0xac373f32, 'Testing CRC matches expected');
|
||||
|
||||
# Bad times die
|
||||
SCOPE: {
|
||||
my @errors = ();
|
||||
local $Archive::Zip::ErrorHandler = sub { push @errors, @_ };
|
||||
eval { Archive::Zip::Member::_unixToDosTime(0) };
|
||||
ok($errors[0] =~ /Tried to add member with zero or undef/,
|
||||
'Got expected _unixToDosTime error');
|
||||
}
|
||||
|
||||
#--------- check time conversion
|
||||
|
||||
foreach my $unix_time (
|
||||
315576062, 315576064, 315580000, 315600000,
|
||||
316000000, 320000000, 400000000, 500000000,
|
||||
600000000, 700000000, 800000000, 900000000,
|
||||
1000000000, 1100000000, 1200000000, int(time() / 2) * 2,
|
||||
) {
|
||||
my $dos_time = Archive::Zip::Member::_unixToDosTime($unix_time);
|
||||
my $round_trip = Archive::Zip::Member::_dosToUnixTime($dos_time);
|
||||
is($unix_time, $round_trip, 'Got expected DOS DateTime value');
|
||||
}
|
||||
|
||||
#####################################################################
|
||||
# Testing Archives
|
||||
|
||||
my $version = Archive::SevenZip->find_7z_executable();
|
||||
if( ! $version ) {
|
||||
SKIP: { skip "7z binary not found (not installed?)", 65; }
|
||||
exit;
|
||||
};
|
||||
diag "7-zip version $version";
|
||||
if( $version <= 9.20) {
|
||||
SKIP: {
|
||||
skip "7z version $version does not support renaming", 65;
|
||||
}
|
||||
exit
|
||||
};
|
||||
|
||||
#--------- empty file
|
||||
# new # Archive::Zip
|
||||
# new # Archive::Zip::Archive
|
||||
my $zip = Archive::SevenZip->archiveZipApi();
|
||||
isa_ok($zip, 'Archive::SevenZip::API::ArchiveZip');
|
||||
|
||||
# members # Archive::Zip::Archive
|
||||
my @members = $zip->members;
|
||||
is(scalar(@members), 0, '->members is 0');
|
||||
|
||||
# numberOfMembers # Archive::Zip::Archive
|
||||
my $numberOfMembers = $zip->numberOfMembers();
|
||||
is($numberOfMembers, 0, '->numberofMembers is 0');
|
||||
|
||||
# writeToFileNamed # Archive::Zip::Archive
|
||||
my $status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK, '->writeToFileNames ok');
|
||||
|
||||
my $zipout;
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
if ($^O eq 'MSWin32') {
|
||||
print STDERR
|
||||
"\n# You might see an expected 'zipfile is empty' warning now.\n";
|
||||
}
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
|
||||
skip("freebsd's unzip doesn't care about empty zips", 1)
|
||||
if $^O eq 'freebsd';
|
||||
|
||||
ok($status != 0);
|
||||
}
|
||||
|
||||
# unzip -t returns error code=1 for warning on empty
|
||||
|
||||
#--------- add a directory
|
||||
my $memberName = TESTDIR() . '/';
|
||||
my $dirName = TESTDIR();
|
||||
|
||||
# addDirectory # Archive::Zip::Archive
|
||||
# new # Archive::Zip::Member
|
||||
my $member = $zip->addDirectory($memberName);
|
||||
ok(defined($member));
|
||||
is($member->fileName(), $memberName);
|
||||
|
||||
# On some (Windows systems) the modification time is
|
||||
# corrupted. Save this to check late.
|
||||
my $dir_time = $member->lastModFileDateTime();
|
||||
|
||||
# members # Archive::Zip::Archive
|
||||
@members = $zip->members();
|
||||
is(scalar(@members), 1);
|
||||
is($members[0]->fileName, $member->fileName);
|
||||
|
||||
# numberOfMembers # Archive::Zip::Archive
|
||||
$numberOfMembers = $zip->numberOfMembers();
|
||||
is($numberOfMembers, 1);
|
||||
|
||||
# writeToFileNamed # Archive::Zip::Archive
|
||||
$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK);
|
||||
|
||||
# Does the modification time get corrupted?
|
||||
is(($zip->members)[0]->lastModFileDateTime(), $dir_time);
|
||||
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
is($status, 0);
|
||||
}
|
||||
|
||||
#--------- extract the directory by name
|
||||
rmtree([TESTDIR()], 0, 0);
|
||||
$status = $zip->extractMember($memberName);
|
||||
is($status, AZ_OK);
|
||||
ok(-d $dirName);
|
||||
|
||||
#--------- extract the directory by identity
|
||||
ok(rmdir($dirName)); # it's still empty
|
||||
$status = $zip->extractMember($member);
|
||||
is($status, AZ_OK);
|
||||
ok(-d $dirName);
|
||||
|
||||
#--------- add a string member, uncompressed
|
||||
$memberName = TESTDIR() . '/string.txt';
|
||||
|
||||
# addString # Archive::Zip::Archive
|
||||
# newFromString # Archive::Zip::Member
|
||||
$member = $zip->addString(TESTSTRING(), $memberName);
|
||||
ok(defined($member));
|
||||
|
||||
is($member->fileName(), $memberName);
|
||||
|
||||
# members # Archive::Zip::Archive
|
||||
@members = $zip->members();
|
||||
is(scalar(@members), 2);
|
||||
#is($members[1]->fileName, $member->fileName);
|
||||
|
||||
# numberOfMembers # Archive::Zip::Archive
|
||||
$numberOfMembers = $zip->numberOfMembers();
|
||||
is($numberOfMembers, 2);
|
||||
|
||||
# writeToFileNamed # Archive::Zip::Archive
|
||||
$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK);
|
||||
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
is($status, 0);
|
||||
}
|
||||
|
||||
is($member->crc32(), TESTSTRINGCRC());
|
||||
|
||||
is($member->crc32String(), sprintf("%08x", TESTSTRINGCRC()));
|
||||
|
||||
#--------- extract it by name
|
||||
$status = $zip->extractMember($memberName);
|
||||
is($status, AZ_OK);
|
||||
ok(-f $memberName);
|
||||
is(fileCRC($memberName), TESTSTRINGCRC());
|
||||
|
||||
#--------- now compress it and re-test
|
||||
#my $oldCompressionMethod =
|
||||
# $member->desiredCompressionMethod(COMPRESSION_DEFLATED);
|
||||
#is($oldCompressionMethod, COMPRESSION_STORED, 'old compression method OK');
|
||||
|
||||
# writeToFileNamed # Archive::Zip::Archive
|
||||
$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK, 'writeToFileNamed returns AZ_OK');
|
||||
is($member->crc32(), TESTSTRINGCRC());
|
||||
is($member->uncompressedSize(), TESTSTRINGLENGTH());
|
||||
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
is($status, 0);
|
||||
}
|
||||
|
||||
#--------- extract it by name
|
||||
$status = $zip->extractMember($memberName);
|
||||
is($status, AZ_OK);
|
||||
ok(-f $memberName);
|
||||
is(fileCRC($memberName), TESTSTRINGCRC());
|
||||
|
||||
#--------- add a file member, compressed
|
||||
ok(rename($memberName, TESTDIR() . '/file.txt'));
|
||||
$memberName = TESTDIR() . '/file.txt';
|
||||
|
||||
# addFile # Archive::Zip::Archive
|
||||
# newFromFile # Archive::Zip::Member
|
||||
$member = $zip->addFile($memberName);
|
||||
ok(defined($member));
|
||||
|
||||
is($member->desiredCompressionMethod(), COMPRESSION_DEFLATED);
|
||||
|
||||
# writeToFileNamed # Archive::Zip::Archive
|
||||
$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK);
|
||||
is($member->crc32(), TESTSTRINGCRC());
|
||||
is($member->uncompressedSize(), TESTSTRINGLENGTH());
|
||||
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
is($status, 0);
|
||||
}
|
||||
|
||||
#--------- extract it by name (note we have to rename it first
|
||||
#--------- or we will clobber the original file
|
||||
my $newName = $memberName;
|
||||
$newName =~ s/\.txt/2.txt/;
|
||||
$status = $zip->extractMember($memberName, $newName);
|
||||
is($status, AZ_OK);
|
||||
ok(-f $newName);
|
||||
is(fileCRC($newName), TESTSTRINGCRC());
|
||||
|
||||
#--------- now make it uncompressed and re-test
|
||||
#$oldCompressionMethod = $member->desiredCompressionMethod(COMPRESSION_STORED);
|
||||
|
||||
#is($oldCompressionMethod, COMPRESSION_DEFLATED);
|
||||
|
||||
# writeToFileNamed # Archive::Zip::Archive
|
||||
$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK);
|
||||
is($member->crc32(), TESTSTRINGCRC());
|
||||
is($member->uncompressedSize(), TESTSTRINGLENGTH());
|
||||
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
is($status, 0);
|
||||
}
|
||||
|
||||
#--------- extract it by name
|
||||
$status = $zip->extractMember($memberName, $newName);
|
||||
is($status, AZ_OK);
|
||||
ok(-f $newName);
|
||||
is(fileCRC($newName), TESTSTRINGCRC());
|
||||
|
||||
# Now, the contents of OUTPUTZIP() are:
|
||||
# Length Method Size Ratio Date Time CRC-32 Name
|
||||
#-------- ------ ------- ----- ---- ---- ------ ----
|
||||
# 0 Stored 0 0% 03-17-00 11:16 00000000 TESTDIR/
|
||||
# 300 Defl:N 146 51% 03-17-00 11:16 ac373f32 TESTDIR/string.txt
|
||||
# 300 Stored 300 0% 03-17-00 11:16 ac373f32 TESTDIR/file.txt
|
||||
#-------- ------- --- -------
|
||||
# 600 446 26% 3 files
|
||||
|
||||
# members # Archive::Zip::Archive
|
||||
@members = $zip->members();
|
||||
is(scalar(@members), 3);
|
||||
is_deeply([map {$_->fileName}
|
||||
grep { $_->fileName eq $member->fileName } @members ],
|
||||
[$member->fileName])
|
||||
or do { diag "Have: " . $_->fileName for @members };
|
||||
|
||||
# memberNames # Archive::Zip::Archive
|
||||
my @memberNames = $zip->memberNames();
|
||||
is(scalar(@memberNames), 3);
|
||||
is_deeply([ grep { $_ eq $member->fileName } @memberNames ],
|
||||
[ $member->fileName ])
|
||||
or do { diag sprintf "[%s]", $member->fileName ; diag sprintf "[%s]", $_->fileName for @members };
|
||||
|
||||
# memberNamed # Archive::Zip::Archive
|
||||
is($zip->memberNamed($memberName)->fileName, $member->fileName);
|
||||
|
||||
# membersMatching # Archive::Zip::Archive
|
||||
@members = $zip->membersMatching('file');
|
||||
is(scalar(@members), 1);
|
||||
is($members[0]->fileName, $member->fileName);
|
||||
|
||||
@members = sort { $a->fileName cmp $b->fileName } $zip->membersMatching('.txt$');
|
||||
is(scalar(@members), 2);
|
||||
is($members[0]->fileName, $member->fileName);
|
||||
|
||||
#--------- remove the string member and test the file
|
||||
# removeMember # Archive::Zip::Archive
|
||||
diag "Removing " . $members[0]->fileName;
|
||||
$member = $zip->removeMember($members[0]);
|
||||
is($member, $members[0]);
|
||||
|
||||
$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
is($status, AZ_OK);
|
||||
|
||||
SKIP: {
|
||||
skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
($status, $zipout) = testZip();
|
||||
|
||||
# STDERR->print("status= $status, out=$zipout\n");
|
||||
skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
is($status, 0);
|
||||
}
|
||||
|
||||
#--------- add the string member at the end and test the file
|
||||
# addMember # Archive::Zip::Archive
|
||||
# This will never work in Archive::SevenZip, transplanting
|
||||
# zip entries in-memory
|
||||
# This also ruins all of the subsequent tests due to the weirdo
|
||||
# approach of not setting up a common baseline for each test
|
||||
# and the insistence on that the implementation maintains the
|
||||
# order on archive members
|
||||
#
|
||||
#$zip->addMember($member);
|
||||
#@members = $zip->members();
|
||||
|
||||
#is(scalar(@members), 3);
|
||||
#is($members[2], $member);
|
||||
|
||||
# memberNames # Archive::Zip::Archive
|
||||
#@memberNames = $zip->memberNames();
|
||||
#is(scalar(@memberNames), 3);
|
||||
#is($memberNames[1], $memberName);
|
||||
|
||||
#$status = $zip->writeToFileNamed(OUTPUTZIP());
|
||||
#is($status, AZ_OK);
|
||||
|
||||
#SKIP: {
|
||||
# skip("No 'unzip' program to test against", 1) unless HAVEUNZIP();
|
||||
# ($status, $zipout) = testZip();
|
||||
|
||||
# # STDERR->print("status= $status, out=$zipout\n");
|
||||
# skip("test zip doesn't work", 1) if $testZipDoesntWork;
|
||||
# is($status, 0);
|
||||
#}
|
|
@ -0,0 +1,59 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
$| = 1;
|
||||
$^W = 1;
|
||||
}
|
||||
use Archive::SevenZip;
|
||||
use FileHandle;
|
||||
use File::Spec;
|
||||
|
||||
use Test::More tests => 2;
|
||||
BEGIN {
|
||||
if( ! eval {
|
||||
require t::common;
|
||||
t::common->import;
|
||||
1
|
||||
}) { SKIP: {
|
||||
skip "Archive::Zip not installed, skipping compatibility tests", 2;
|
||||
}
|
||||
exit;
|
||||
}}
|
||||
|
||||
my $version = Archive::SevenZip->find_7z_executable();
|
||||
if( ! $version ) {
|
||||
SKIP: { skip "7z binary not found (not installed?)", 2; }
|
||||
exit;
|
||||
};
|
||||
|
||||
|
||||
use constant FILENAME => File::Spec->catfile(TESTDIR(), 'testing.txt');
|
||||
|
||||
my $zip;
|
||||
my @memberNames;
|
||||
|
||||
sub makeZip {
|
||||
my ($src, $dest, $pred) = @_;
|
||||
$zip = Archive::SevenZip->archiveZipApi();
|
||||
$zip->addTree($src, $dest,);
|
||||
@memberNames = $zip->memberNames();
|
||||
}
|
||||
|
||||
sub makeZipAndLookFor {
|
||||
my ($src, $dest, $pred, $lookFor) = @_;
|
||||
makeZip($src, $dest, $pred);
|
||||
ok(@memberNames);
|
||||
ok((grep { $_ eq $lookFor } @memberNames) == 1)
|
||||
or print STDERR "Can't find $lookFor in ("
|
||||
. join(",", @memberNames) . ")\n";
|
||||
}
|
||||
|
||||
my ($testFileVolume, $testFileDirs, $testFileName) = File::Spec->splitpath($0);
|
||||
|
||||
makeZipAndLookFor('.', '', sub { print "file $_\n"; -f && /\.t$/ },
|
||||
't/02_main.t');
|
||||
# Not supported:
|
||||
#makeZipAndLookFor('.', 'e/', sub { -f && /\.t$/ }, 'e/t/02_main.t');
|
||||
#makeZipAndLookFor('./t', '', sub { -f && /\.t$/ }, '02_main.t');
|
|
@ -0,0 +1,59 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
# Github 11: "CRC or size mismatch" when extracting member second time
|
||||
# Test for correct functionality to prevent regression
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Archive::SevenZip 'AZ_OK';
|
||||
use File::Spec;
|
||||
use File::Path;
|
||||
|
||||
use Test::More;
|
||||
|
||||
BEGIN {
|
||||
if( ! eval {
|
||||
require t::common;
|
||||
t::common->import;
|
||||
1
|
||||
}) {
|
||||
plan skip_all => "Archive::Zip not installed, skipping compatibility tests";
|
||||
exit;
|
||||
}
|
||||
else {
|
||||
plan tests => 2;
|
||||
}
|
||||
}
|
||||
|
||||
my $version = Archive::SevenZip->find_7z_executable();
|
||||
if( ! $version ) {
|
||||
SKIP: { skip "7z binary not found (not installed?)", 2; };
|
||||
exit
|
||||
};
|
||||
diag "7-zip version $version";
|
||||
|
||||
# create test env
|
||||
my $GH_ISSUE = 'github11';
|
||||
my $TEST_NAME = "20_bug_$GH_ISSUE";
|
||||
my $TEST_DIR = File::Spec->catdir(TESTDIR, $TEST_NAME);
|
||||
mkpath($TEST_DIR);
|
||||
|
||||
# test 1
|
||||
my $DATA_DIR = File::Spec->catfile('t', 'data');
|
||||
my $GOOD_ZIP_FILE = File::Spec->catfile($DATA_DIR, "good_${GH_ISSUE}.zip");
|
||||
my $GOOD_ZIP = Archive::SevenZip->new($GOOD_ZIP_FILE);
|
||||
my $MEMBER_FILE = 'FILE';
|
||||
my $member = $GOOD_ZIP->memberNamed($MEMBER_FILE);
|
||||
my $OUT_FILE = File::Spec->catfile($TEST_DIR, "out");
|
||||
# Extracting twice triggered the bug
|
||||
$member->extractToFileNamed($OUT_FILE);
|
||||
is($member->extractToFileNamed($OUT_FILE), AZ_OK, 'Testing known good zip');
|
||||
|
||||
# test 2
|
||||
my $BAD_ZIP_FILE = File::Spec->catfile($DATA_DIR, "bad_${GH_ISSUE}.zip");
|
||||
my $BAD_ZIP = Archive::SevenZip->new($BAD_ZIP_FILE);
|
||||
$member = $BAD_ZIP->memberNamed($MEMBER_FILE);
|
||||
# Extracting twice triggered the bug
|
||||
$member->extractToFileNamed($OUT_FILE);
|
||||
is($member->extractToFileNamed($OUT_FILE), AZ_OK, 'Testing known bad zip');
|
Binary file not shown.
After Width: | Height: | Size: 56 KiB |
Binary file not shown.
|
@ -0,0 +1,257 @@
|
|||
use strict;
|
||||
|
||||
# Shared defs for test programs
|
||||
|
||||
# Paths. Must make case-insensitive.
|
||||
use File::Temp qw(tempfile tempdir);
|
||||
use File::Spec;
|
||||
BEGIN { mkdir 'testdir' }
|
||||
use constant TESTDIR => do {
|
||||
my $tmpdir = File::Spec->abs2rel(tempdir(DIR => 'testdir', CLEANUP => 1));
|
||||
$tmpdir =~ s!\\!/!g if $^O eq 'MSWin32';
|
||||
$tmpdir
|
||||
};
|
||||
use constant INPUTZIP =>
|
||||
(tempfile('testin-XXXXX', SUFFIX => '.zip', TMPDIR => 1, $^O eq 'MSWin32' ? () : (UNLINK => 1)))[1];
|
||||
use constant OUTPUTZIP =>
|
||||
(tempfile('testout-XXXXX', SUFFIX => '.zip', TMPDIR => 1, $^O eq 'MSWin32' ? () : (UNLINK => 1)))[1];
|
||||
|
||||
# Do we have the 'zip' and 'unzip' programs?
|
||||
# Embed a copy of the module, rather than adding a dependency
|
||||
BEGIN {
|
||||
|
||||
package File::Which;
|
||||
|
||||
use File::Spec;
|
||||
|
||||
my $Is_VMS = ($^O eq 'VMS');
|
||||
my $Is_MacOS = ($^O eq 'MacOS');
|
||||
my $Is_DOSish =
|
||||
(($^O eq 'MSWin32') or ($^O eq 'dos') or ($^O eq 'os2'));
|
||||
|
||||
# For Win32 systems, stores the extensions used for
|
||||
# executable files
|
||||
# For others, the empty string is used
|
||||
# because 'perl' . '' eq 'perl' => easier
|
||||
my @path_ext = ('');
|
||||
if ($Is_DOSish) {
|
||||
if ($ENV{PATHEXT} and $Is_DOSish)
|
||||
{ # WinNT. PATHEXT might be set on Cygwin, but not used.
|
||||
push @path_ext, split ';', $ENV{PATHEXT};
|
||||
} else {
|
||||
push @path_ext, qw(.com .exe .bat)
|
||||
; # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
|
||||
}
|
||||
} elsif ($Is_VMS) {
|
||||
push @path_ext, qw(.exe .com);
|
||||
}
|
||||
|
||||
sub which {
|
||||
my ($exec) = @_;
|
||||
|
||||
return undef unless $exec;
|
||||
|
||||
my $all = wantarray;
|
||||
my @results = ();
|
||||
|
||||
# check for aliases first
|
||||
if ($Is_VMS) {
|
||||
my $symbol = `SHOW SYMBOL $exec`;
|
||||
chomp($symbol);
|
||||
if (!$?) {
|
||||
return $symbol unless $all;
|
||||
push @results, $symbol;
|
||||
}
|
||||
}
|
||||
if ($Is_MacOS) {
|
||||
my @aliases = split /\,/, $ENV{Aliases};
|
||||
foreach my $alias (@aliases) {
|
||||
|
||||
# This has not been tested!!
|
||||
# PPT which says MPW-Perl cannot resolve `Alias $alias`,
|
||||
# let's just hope it's fixed
|
||||
if (lc($alias) eq lc($exec)) {
|
||||
chomp(my $file = `Alias $alias`);
|
||||
last unless $file; # if it failed, just go on the normal way
|
||||
return $file unless $all;
|
||||
push @results, $file;
|
||||
|
||||
# we can stop this loop as if it finds more aliases matching,
|
||||
# it'll just be the same result anyway
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my @path = File::Spec->path();
|
||||
unshift @path, File::Spec->curdir if $Is_DOSish or $Is_VMS or $Is_MacOS;
|
||||
|
||||
for my $base (map { File::Spec->catfile($_, $exec) } @path) {
|
||||
for my $ext (@path_ext) {
|
||||
my $file = $base . $ext;
|
||||
|
||||
# print STDERR "$file\n";
|
||||
|
||||
if (
|
||||
(
|
||||
-x $file or # executable, normal case
|
||||
(
|
||||
$Is_MacOS
|
||||
|| # MacOS doesn't mark as executable so we check -e
|
||||
(
|
||||
$Is_DOSish
|
||||
and grep { $file =~ /$_$/i }
|
||||
@path_ext[1 .. $#path_ext])
|
||||
|
||||
# DOSish systems don't pass -x on non-exe/bat/com files.
|
||||
# so we check -e. However, we don't want to pass -e on files
|
||||
# that aren't in PATHEXT, like README.
|
||||
and -e _))
|
||||
and !-d _)
|
||||
{ # and finally, we don't want dirs to pass (as they are -x)
|
||||
|
||||
# print STDERR "-x: ", -x $file, " -e: ", -e _, " -d: ", -d _, "\n";
|
||||
|
||||
return $file unless $all;
|
||||
push @results, $file; # Make list to return later
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($all) {
|
||||
return @results;
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
}
|
||||
use constant HAVEZIP => !!File::Which::which('zip');
|
||||
use constant HAVEUNZIP => !!File::Which::which('unzip');
|
||||
|
||||
use constant ZIP => 'zip ';
|
||||
use constant ZIPTEST => 'unzip -t ';
|
||||
|
||||
# 300-character test string
|
||||
use constant TESTSTRING => join("\n", 1 .. 102) . "\n";
|
||||
use constant TESTSTRINGLENGTH => length(TESTSTRING);
|
||||
|
||||
use Archive::Zip ();
|
||||
|
||||
# CRC-32 should be ac373f32
|
||||
use constant TESTSTRINGCRC => Archive::Zip::computeCRC32(TESTSTRING);
|
||||
|
||||
# This is so that it will work on other systems.
|
||||
use constant CAT => $^X . ' -pe "BEGIN{binmode(STDIN);binmode(STDOUT)}"';
|
||||
use constant CATPIPE => '| ' . CAT . ' >';
|
||||
|
||||
use vars qw($zipWorks $testZipDoesntWork $catWorks);
|
||||
|
||||
# Run ZIPTEST to test a zip file.
|
||||
sub testZip {
|
||||
my $zipName = shift || OUTPUTZIP;
|
||||
if ($testZipDoesntWork) {
|
||||
return wantarray ? (0, '') : 0;
|
||||
}
|
||||
my $cmd = ZIPTEST . $zipName . ($^O eq 'MSWin32' ? '' : ' 2>&1');
|
||||
my $zipout = `$cmd`;
|
||||
return wantarray ? ($?, $zipout) : $?;
|
||||
}
|
||||
|
||||
# Return the crc-32 of the given file (0 if empty or error)
|
||||
sub fileCRC {
|
||||
my $fileName = shift;
|
||||
local $/ = undef;
|
||||
my $fh = IO::File->new($fileName, "r");
|
||||
binmode($fh);
|
||||
return 0 if not defined($fh);
|
||||
my $contents = <$fh>;
|
||||
return Archive::Zip::computeCRC32($contents);
|
||||
}
|
||||
|
||||
#--------- check to see if cat works
|
||||
|
||||
sub testCat {
|
||||
my $fh = IO::File->new(CATPIPE . OUTPUTZIP);
|
||||
binmode($fh);
|
||||
my $testString = pack('C256', 0 .. 255);
|
||||
my $testCrc = Archive::Zip::computeCRC32($testString);
|
||||
$fh->write($testString, length($testString)) or return 0;
|
||||
$fh->close();
|
||||
(-f OUTPUTZIP) or return 0;
|
||||
my @stat = stat(OUTPUTZIP);
|
||||
$stat[7] == length($testString) or return 0;
|
||||
fileCRC(OUTPUTZIP) == $testCrc or return 0;
|
||||
unlink(OUTPUTZIP);
|
||||
return 1;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
$catWorks = testCat();
|
||||
unless ($catWorks) {
|
||||
warn('warning: ', CAT, " doesn't seem to work, may skip some tests");
|
||||
}
|
||||
}
|
||||
|
||||
#--------- check to see if zip works (and make INPUTZIP)
|
||||
|
||||
BEGIN {
|
||||
unlink(INPUTZIP);
|
||||
|
||||
# Do we have zip installed?
|
||||
if (HAVEZIP) {
|
||||
my $cmd = ZIP . INPUTZIP . ' *' . ($^O eq 'MSWin32' ? '' : ' 2>&1');
|
||||
my $zipout = `$cmd`;
|
||||
$zipWorks = not $?;
|
||||
unless ($zipWorks) {
|
||||
warn('warning: ', ZIP,
|
||||
" doesn't seem to work, may skip some tests");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#--------- check to see if unzip -t works
|
||||
|
||||
BEGIN {
|
||||
$testZipDoesntWork = 1;
|
||||
if (HAVEUNZIP) {
|
||||
my ($status, $zipout) = do { local $testZipDoesntWork = 0; testZip(INPUTZIP) };
|
||||
$testZipDoesntWork = $status;
|
||||
|
||||
# Again, on Win32 no big surprise if this doesn't work
|
||||
if ($testZipDoesntWork) {
|
||||
warn('warning: ', ZIPTEST,
|
||||
" doesn't seem to work, may skip some tests");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub passthrough
|
||||
{
|
||||
my $fromFile = shift ;
|
||||
my $toFile = shift ;
|
||||
my $action = shift ;
|
||||
|
||||
my $z = Archive::Zip->new;
|
||||
$z->read($fromFile);
|
||||
if ($action)
|
||||
{
|
||||
for my $member($z->members())
|
||||
{
|
||||
&$action($member) ;
|
||||
}
|
||||
}
|
||||
$z->writeToFileNamed($toFile);
|
||||
}
|
||||
|
||||
sub readFile
|
||||
{
|
||||
my $name = shift ;
|
||||
local $/;
|
||||
open F, "<$name"
|
||||
or die "Cannot open $name: $!\n";
|
||||
my $data = <F>;
|
||||
close F ;
|
||||
return $data;
|
||||
}
|
||||
|
||||
1;
|
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
@ -0,0 +1 @@
|
|||
abc
|
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
@ -0,0 +1,54 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
#This script will create test zip files used by some of the tests.
|
||||
#
|
||||
# File Length Streamed Method
|
||||
# ===============================================
|
||||
# emptydef.zip Yes No Deflate
|
||||
# emptydefstr.zip Yes Yes Deflate
|
||||
# emptystore.zip Yes No Store
|
||||
# emptystorestr.zip Yes Yes Store
|
||||
#
|
||||
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use IO::Compress::Zip qw(:all);
|
||||
|
||||
my $time = 325532800;
|
||||
|
||||
zip \"" => "emptydef.zip",
|
||||
Name => "fred", Stream => 0, Method => ZIP_CM_DEFLATE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
zip \"" => "emptydefstr.zip",
|
||||
Name => "fred", Stream => 1, Method => ZIP_CM_DEFLATE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
zip \"" => "emptystore.zip",
|
||||
Name => "fred", Stream => 0, Method => ZIP_CM_STORE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
zip \"" => "emptystorestr.zip",
|
||||
Name => "fred", Stream => 1, Method => ZIP_CM_STORE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
|
||||
|
||||
zip \"abc" => "def.zip",
|
||||
Name => "fred", Stream => 0, Method => ZIP_CM_DEFLATE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
zip \"abc" => "defstr.zip",
|
||||
Name => "fred", Stream => 1, Method => ZIP_CM_DEFLATE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
zip \"abc" => "store.zip",
|
||||
Name => "fred", Stream => 0, Method => ZIP_CM_STORE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
||||
zip \"abc" => "storestr.zip",
|
||||
Name => "fred", Stream => 1, Method => ZIP_CM_STORE, Time => $time
|
||||
or die "Cannot create zip: $ZipError";
|
||||
|
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
@ -0,0 +1,28 @@
|
|||
#!perl -w
|
||||
use warnings;
|
||||
use strict;
|
||||
use File::Find;
|
||||
use Test::More tests => 2;
|
||||
|
||||
=head1 PURPOSE
|
||||
|
||||
This test ensures that the Changes file
|
||||
mentions the current version and that a
|
||||
release date is mentioned as well
|
||||
|
||||
=cut
|
||||
|
||||
my $module = 'Archive::SevenZip';
|
||||
|
||||
(my $file = $module) =~ s!::!/!g;
|
||||
require "$file.pm";
|
||||
|
||||
my $version = sprintf '%0.2f', $module->VERSION;
|
||||
diag "Checking for version " . $version;
|
||||
|
||||
my $changes = do { local $/; open my $fh, 'Changes' or die $!; <$fh> };
|
||||
|
||||
ok $changes =~ /^(.*$version.*)$/m, "We find version $version";
|
||||
my $changes_line = $1;
|
||||
ok $changes_line =~ /$version\s+20\d{6}/, "We find a release date on the same line"
|
||||
or diag $changes_line;
|
|
@ -0,0 +1,43 @@
|
|||
#!perl -w
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use File::Find;
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
eval 'use Capture::Tiny ":all"; 1';
|
||||
if ($@) {
|
||||
plan skip_all => "Capture::Tiny needed for testing";
|
||||
exit 0;
|
||||
};
|
||||
};
|
||||
|
||||
plan 'no_plan';
|
||||
|
||||
my $last_version = undef;
|
||||
|
||||
sub check {
|
||||
return if (! m{(\.pm|\.pl) \z}xmsi);
|
||||
|
||||
my ($stdout, $stderr, $exit) = capture(sub {
|
||||
system( $^X, '-Mblib', '-wc', $_ );
|
||||
});
|
||||
|
||||
s!\s*\z!!
|
||||
for ($stdout, $stderr);
|
||||
|
||||
if( $exit ) {
|
||||
diag $exit;
|
||||
fail($_);
|
||||
} elsif( $stderr ne "$_ syntax OK") {
|
||||
diag $stderr;
|
||||
fail($_);
|
||||
} else {
|
||||
pass($_);
|
||||
};
|
||||
}
|
||||
|
||||
find({wanted => \&check, no_chdir => 1},
|
||||
grep { -d $_ }
|
||||
'blib', 'scripts', 'examples', 'bin', 'lib'
|
||||
);
|
|
@ -0,0 +1,31 @@
|
|||
use strict;
|
||||
use Test::More;
|
||||
|
||||
# Check that MANIFEST and MANIFEST.skip are sane :
|
||||
|
||||
use File::Find;
|
||||
use File::Spec;
|
||||
|
||||
my @files = qw( MANIFEST MANIFEST.SKIP );
|
||||
plan tests => scalar @files * 4
|
||||
+1 # MANIFEST existence check
|
||||
;
|
||||
|
||||
for my $file (@files) {
|
||||
ok(-f $file, "$file exists");
|
||||
open F, "<$file"
|
||||
or die "Couldn't open $file : $!";
|
||||
my @lines = <F>;
|
||||
is_deeply([grep(/^$/, @lines)],[], "No empty lines in $file");
|
||||
is_deeply([grep(/^\s+$/, @lines)],[], "No whitespace-only lines in $file");
|
||||
is_deeply([grep(/^\s*\S\s+$/, @lines)],[],"No trailing whitespace on lines in $file");
|
||||
|
||||
if ($file eq 'MANIFEST') {
|
||||
chomp @lines;
|
||||
is_deeply([grep { s/\s.*//; ! -f } @lines], [], "All files in $file exist")
|
||||
or do { diag "$_ is mentioned in $file but doesn't exist on disk" for grep { ! -f } @lines };
|
||||
};
|
||||
|
||||
close F;
|
||||
};
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
#!perl -w
|
||||
use strict;
|
||||
use Test::More;
|
||||
|
||||
eval {
|
||||
require Test::MinimumVersion::Fast;
|
||||
Test::MinimumVersion::Fast->import;
|
||||
};
|
||||
|
||||
my @files;
|
||||
|
||||
if ($@) {
|
||||
plan skip_all => "Test::MinimumVersion::Fast required for testing minimum Perl version";
|
||||
}
|
||||
else {
|
||||
all_minimum_version_from_metayml_ok();
|
||||
}
|
|
@ -0,0 +1,36 @@
|
|||
use Test::More;
|
||||
|
||||
# Check our Pod
|
||||
# The test was provided by Andy Lester,
|
||||
# who stole it from Brian D. Foy
|
||||
# Thanks to both !
|
||||
|
||||
use File::Spec;
|
||||
use File::Find;
|
||||
use strict;
|
||||
|
||||
eval {
|
||||
require Test::Pod;
|
||||
Test::Pod->import;
|
||||
};
|
||||
|
||||
my @files;
|
||||
|
||||
if ($@) {
|
||||
plan skip_all => "Test::Pod required for testing POD";
|
||||
}
|
||||
elsif ($Test::Pod::VERSION < 0.95) {
|
||||
plan skip_all => "Test::Pod 0.95 required for testing POD";
|
||||
}
|
||||
else {
|
||||
my $blib = File::Spec->catfile(qw(blib lib));
|
||||
find(\&wanted, grep { -d } ($blib, 'bin'));
|
||||
plan tests => scalar @files;
|
||||
foreach my $file (@files) {
|
||||
pod_file_ok($file);
|
||||
}
|
||||
}
|
||||
|
||||
sub wanted {
|
||||
push @files, $File::Find::name if /\.p(l|m|od)$/;
|
||||
}
|
|
@ -0,0 +1,47 @@
|
|||
use Test::More;
|
||||
use File::Spec;
|
||||
use File::Find;
|
||||
use strict;
|
||||
|
||||
# Check that all files do not contain any
|
||||
# lines with "XXX" - such markers should
|
||||
# either have been converted into Todo-stuff
|
||||
# or have been resolved.
|
||||
# The test was provided by Andy Lester.
|
||||
|
||||
my @files;
|
||||
my $blib = File::Spec->catfile(qw(blib lib));
|
||||
find(\&wanted, grep { -d } ($blib, 'bin'));
|
||||
plan tests => 2* @files;
|
||||
foreach my $file (@files) {
|
||||
source_file_ok($file);
|
||||
}
|
||||
|
||||
sub wanted {
|
||||
push @files, $File::Find::name if /\.p(l|m|od)$/;
|
||||
}
|
||||
|
||||
sub source_file_ok {
|
||||
my $file = shift;
|
||||
|
||||
open( my $fh, "<$file" ) or die "Can't open $file: $!";
|
||||
my @lines = <$fh>;
|
||||
close $fh;
|
||||
|
||||
my $n = 0;
|
||||
for ( @lines ) {
|
||||
++$n;
|
||||
s/^/$file ($n): /;
|
||||
}
|
||||
|
||||
my @x = grep /XXX/, @lines;
|
||||
|
||||
if ( !is( scalar @x, 0, "Looking for XXXes in $file" ) ) {
|
||||
diag( $_ ) for @x;
|
||||
}
|
||||
@x = grep /<<<|>>>/, @lines;
|
||||
|
||||
if ( !is( scalar @x, 0, "Looking for <<<<|>>>> in $file" ) ) {
|
||||
diag( $_ ) for @x;
|
||||
}
|
||||
}
|
|
@ -0,0 +1,37 @@
|
|||
use Test::More;
|
||||
|
||||
# Check that all released module files are in
|
||||
# UNIX text format
|
||||
|
||||
use File::Spec;
|
||||
use File::Find;
|
||||
use strict;
|
||||
|
||||
my @files;
|
||||
|
||||
my $blib = File::Spec->catfile(qw(blib lib));
|
||||
find(\&wanted, grep { -d } ($blib, 'bin'));
|
||||
plan tests => scalar @files;
|
||||
foreach my $file (@files) {
|
||||
unix_file_ok($file);
|
||||
}
|
||||
|
||||
sub wanted {
|
||||
push @files, $File::Find::name if /\.p(l|m|od)$/;
|
||||
}
|
||||
|
||||
sub unix_file_ok {
|
||||
my ($filename) = @_;
|
||||
local $/;
|
||||
open F, "< $filename"
|
||||
or die "Couldn't open '$filename' : $!\n";
|
||||
binmode F;
|
||||
my $content = <F>;
|
||||
|
||||
my $i;
|
||||
my @lines = grep { /\x0D\x0A$/sm } map { sprintf "%s: %s\x0A", $i++, $_ } split /\x0A/, $content;
|
||||
unless (is(scalar @lines, 0,"'$filename' contains no windows newlines")) {
|
||||
diag $_ for @lines;
|
||||
};
|
||||
close F;
|
||||
};
|
|
@ -0,0 +1,51 @@
|
|||
#!perl -w
|
||||
|
||||
# Stolen from ChrisDolan on use.perl.org
|
||||
# http://use.perl.org/comments.pl?sid=29264&cid=44309
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use File::Find;
|
||||
use Test::More;
|
||||
BEGIN {
|
||||
eval 'use File::Slurp; 1';
|
||||
if ($@) {
|
||||
plan skip_all => "File::Slurp needed for testing";
|
||||
exit 0;
|
||||
};
|
||||
};
|
||||
|
||||
plan 'no_plan';
|
||||
|
||||
my $last_version = undef;
|
||||
|
||||
sub check {
|
||||
return if (! m{blib/script/}xms && ! m{\.pm \z}xms);
|
||||
|
||||
my $content = read_file($_);
|
||||
|
||||
# only look at perl scripts, not sh scripts
|
||||
return if (m{blib/script/}xms && $content !~ m/\A \#![^\r\n]+?perl/xms);
|
||||
|
||||
my @version_lines = $content =~ m/ ( [^\n]* \$VERSION \s* = [^=] [^\n]* ) /gxms;
|
||||
if (@version_lines == 0) {
|
||||
fail($_);
|
||||
}
|
||||
for my $line (@version_lines) {
|
||||
$line =~ s/^\s+//;
|
||||
$line =~ s/\s+$//;
|
||||
if (!defined $last_version) {
|
||||
$last_version = shift @version_lines;
|
||||
diag "Checking for $last_version";
|
||||
pass($_);
|
||||
} else {
|
||||
is($line, $last_version, $_);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
find({wanted => \&check, no_chdir => 1}, 'blib');
|
||||
|
||||
if (! defined $last_version) {
|
||||
fail('Failed to find any files with $VERSION');
|
||||
}
|
Loading…
Reference in New Issue