commit fd6c0eeda315a0cf1dacea1c0dbf74ff971cfbca Author: Mario Fetka Date: Thu Sep 14 11:26:13 2017 +0200 Imported Upstream version 0.06 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e3e1e31 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +Makefile +Makefile.old +*.tar.gz +*.bak +pm_to_blib +blib/ +Archive-SevenZip-*/ +Archive-SevenZip-* +.releaserc +cover_db +MYMETA.* diff --git a/Changes b/Changes new file mode 100644 index 0000000..ff3782d --- /dev/null +++ b/Changes @@ -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 diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..7b4a21d --- /dev/null +++ b/MANIFEST @@ -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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..e1d3db1 --- /dev/null +++ b/MANIFEST.SKIP @@ -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$ diff --git a/META.json b/META.json new file mode 100644 index 0000000..f456c85 --- /dev/null +++ b/META.json @@ -0,0 +1,31 @@ +{ + "abstract" : "Read/write 7z , zip , ISO9960 and other archives", + "author" : [ + "Max Maischein " + ], + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..ca6eef6 --- /dev/null +++ b/META.yml @@ -0,0 +1,19 @@ +--- +abstract: 'Read/write 7z , zip , ISO9960 and other archives' +author: + - 'Max Maischein ' +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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4c3063d --- /dev/null +++ b/Makefile.PL @@ -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 }, + 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; + }; +} + diff --git a/lib/Archive/SevenZip.pm b/lib/Archive/SevenZip.pm new file mode 100644 index 0000000..4585698 --- /dev/null +++ b/lib/Archive/SevenZip.pm @@ -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 +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 - 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 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 in some cases +and in other cases, the API of L. It is also a very rough +draft that just happens to be doing what I need, mostly extracting +files. + +=head1 SEE ALSO + +L - also supports unpacking from 7z archives + +L - uncompressor for the LZMA compression method used by 7z + +=head1 REPOSITORY + +The public repository of this module is +L. + +=head1 SUPPORT + +The public support forum of this module is +L. + +=head1 BUG TRACKER + +Please report bugs in this module via the RT CPAN bug queue at +L +or via mail to L. + +=head1 AUTHOR + +Max Maischein C + +=head1 COPYRIGHT (c) + +Copyright 2015-2016 by Max Maischein C. + +=head1 LICENSE + +This module is released under the same terms as Perl itself. + +=cut diff --git a/lib/Archive/SevenZip/API/ArchiveZip.pm b/lib/Archive/SevenZip/API/ArchiveZip.pm new file mode 100644 index 0000000..710d4a8 --- /dev/null +++ b/lib/Archive/SevenZip/API/ArchiveZip.pm @@ -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 +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. + +=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. + +=head1 SUPPORT + +The public support forum of this module is +L. + +=head1 BUG TRACKER + +Please report bugs in this module via the RT CPAN bug queue at +L +or via mail to L. + +=head1 AUTHOR + +Max Maischein C + +=head1 COPYRIGHT (c) + +Copyright 2015-2016 by Max Maischein C. + +=head1 LICENSE + +This module is released under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Archive/SevenZip/Entry.pm b/lib/Archive/SevenZip/Entry.pm new file mode 100644 index 0000000..54cd713 --- /dev/null +++ b/lib/Archive/SevenZip/Entry.pm @@ -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. + +=head1 SUPPORT + +The public support forum of this module is +L. + +=head1 BUG TRACKER + +Please report bugs in this module via the RT CPAN bug queue at +L +or via mail to L. + +=head1 AUTHOR + +Max Maischein C + +=head1 COPYRIGHT (c) + +Copyright 2015-2016 by Max Maischein C. + +=head1 LICENSE + +This module is released under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/01-identity.t b/t/01-identity.t new file mode 100644 index 0000000..f8cad0d --- /dev/null +++ b/t/01-identity.t @@ -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" ); + diff --git a/t/02-add-scalar.t b/t/02-add-scalar.t new file mode 100644 index 0000000..12386d1 --- /dev/null +++ b/t/02-add-scalar.t @@ -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"; + diff --git a/t/02_main.t b/t/02_main.t new file mode 100644 index 0000000..2c98572 --- /dev/null +++ b/t/02_main.t @@ -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); +#} diff --git a/t/05_tree.t b/t/05_tree.t new file mode 100644 index 0000000..dbb6edd --- /dev/null +++ b/t/05_tree.t @@ -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'); diff --git a/t/20_bug_github11.t b/t/20_bug_github11.t new file mode 100644 index 0000000..fb397ee --- /dev/null +++ b/t/20_bug_github11.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'); diff --git a/t/badjpeg/expected.jpg b/t/badjpeg/expected.jpg new file mode 100644 index 0000000..0b362db Binary files /dev/null and b/t/badjpeg/expected.jpg differ diff --git a/t/badjpeg/source.zip b/t/badjpeg/source.zip new file mode 100644 index 0000000..7ad9663 Binary files /dev/null and b/t/badjpeg/source.zip differ diff --git a/t/common.pm b/t/common.pm new file mode 100644 index 0000000..cff8f78 --- /dev/null +++ b/t/common.pm @@ -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 = ; + close F ; + return $data; +} + +1; diff --git a/t/data/bad_github11.zip b/t/data/bad_github11.zip new file mode 100644 index 0000000..3fe4892 Binary files /dev/null and b/t/data/bad_github11.zip differ diff --git a/t/data/chmod.zip b/t/data/chmod.zip new file mode 100644 index 0000000..fccda55 Binary files /dev/null and b/t/data/chmod.zip differ diff --git a/t/data/crypcomp.zip b/t/data/crypcomp.zip new file mode 100644 index 0000000..cd4d1e8 Binary files /dev/null and b/t/data/crypcomp.zip differ diff --git a/t/data/crypt.zip b/t/data/crypt.zip new file mode 100644 index 0000000..d1c897f Binary files /dev/null and b/t/data/crypt.zip differ diff --git a/t/data/def.zip b/t/data/def.zip new file mode 100644 index 0000000..2c2890f Binary files /dev/null and b/t/data/def.zip differ diff --git a/t/data/defstr.zip b/t/data/defstr.zip new file mode 100644 index 0000000..60591d1 Binary files /dev/null and b/t/data/defstr.zip differ diff --git a/t/data/emptydef.zip b/t/data/emptydef.zip new file mode 100644 index 0000000..87b26a3 Binary files /dev/null and b/t/data/emptydef.zip differ diff --git a/t/data/emptydefstr.zip b/t/data/emptydefstr.zip new file mode 100644 index 0000000..074bea2 Binary files /dev/null and b/t/data/emptydefstr.zip differ diff --git a/t/data/emptystore.zip b/t/data/emptystore.zip new file mode 100644 index 0000000..b3e98d8 Binary files /dev/null and b/t/data/emptystore.zip differ diff --git a/t/data/emptystorestr.zip b/t/data/emptystorestr.zip new file mode 100644 index 0000000..2c80dde Binary files /dev/null and b/t/data/emptystorestr.zip differ diff --git a/t/data/fred b/t/data/fred new file mode 100644 index 0000000..f2ba8f8 --- /dev/null +++ b/t/data/fred @@ -0,0 +1 @@ +abc \ No newline at end of file diff --git a/t/data/good_github11.zip b/t/data/good_github11.zip new file mode 100644 index 0000000..39ee392 Binary files /dev/null and b/t/data/good_github11.zip differ diff --git a/t/data/jar.zip b/t/data/jar.zip new file mode 100644 index 0000000..a8da50f Binary files /dev/null and b/t/data/jar.zip differ diff --git a/t/data/linux.zip b/t/data/linux.zip new file mode 100644 index 0000000..3f8e449 Binary files /dev/null and b/t/data/linux.zip differ diff --git a/t/data/mkzip.pl b/t/data/mkzip.pl new file mode 100644 index 0000000..b445846 --- /dev/null +++ b/t/data/mkzip.pl @@ -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"; + diff --git a/t/data/perl.zip b/t/data/perl.zip new file mode 100644 index 0000000..0430db3 Binary files /dev/null and b/t/data/perl.zip differ diff --git a/t/data/store.zip b/t/data/store.zip new file mode 100644 index 0000000..f8e4496 Binary files /dev/null and b/t/data/store.zip differ diff --git a/t/data/storestr.zip b/t/data/storestr.zip new file mode 100644 index 0000000..cc97102 Binary files /dev/null and b/t/data/storestr.zip differ diff --git a/t/data/streamed.zip b/t/data/streamed.zip new file mode 100644 index 0000000..90c0ed3 Binary files /dev/null and b/t/data/streamed.zip differ diff --git a/t/data/winzip.zip b/t/data/winzip.zip new file mode 100644 index 0000000..d8b1f0c Binary files /dev/null and b/t/data/winzip.zip differ diff --git a/t/data/zip64.zip b/t/data/zip64.zip new file mode 100644 index 0000000..a2ee1fa Binary files /dev/null and b/t/data/zip64.zip differ diff --git a/xt/99-changes.t b/xt/99-changes.t new file mode 100644 index 0000000..c383123 --- /dev/null +++ b/xt/99-changes.t @@ -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; diff --git a/xt/99-compile.t b/xt/99-compile.t new file mode 100644 index 0000000..0bd8be6 --- /dev/null +++ b/xt/99-compile.t @@ -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' + ); diff --git a/xt/99-manifest.t b/xt/99-manifest.t new file mode 100644 index 0000000..4a54e92 --- /dev/null +++ b/xt/99-manifest.t @@ -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 = ; + 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; +}; + diff --git a/xt/99-minimumversion.t b/xt/99-minimumversion.t new file mode 100644 index 0000000..d649b7a --- /dev/null +++ b/xt/99-minimumversion.t @@ -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(); +} diff --git a/xt/99-pod.t b/xt/99-pod.t new file mode 100644 index 0000000..079bc40 --- /dev/null +++ b/xt/99-pod.t @@ -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)$/; +} diff --git a/xt/99-todo.t b/xt/99-todo.t new file mode 100644 index 0000000..17f8aef --- /dev/null +++ b/xt/99-todo.t @@ -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; + } +} diff --git a/xt/99-unix-text.t b/xt/99-unix-text.t new file mode 100644 index 0000000..f91c526 --- /dev/null +++ b/xt/99-unix-text.t @@ -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 = ; + + 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; +}; diff --git a/xt/99-versions.t b/xt/99-versions.t new file mode 100644 index 0000000..49da187 --- /dev/null +++ b/xt/99-versions.t @@ -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'); +}