Compare commits
No commits in common. "master" and "pristine-tar" have entirely different histories.
master
...
pristine-t
11
.gitignore
vendored
11
.gitignore
vendored
@ -1,11 +0,0 @@
|
|||||||
Makefile
|
|
||||||
Makefile.old
|
|
||||||
*.tar.gz
|
|
||||||
*.bak
|
|
||||||
pm_to_blib
|
|
||||||
blib/
|
|
||||||
Archive-SevenZip-*/
|
|
||||||
Archive-SevenZip-*
|
|
||||||
.releaserc
|
|
||||||
cover_db
|
|
||||||
MYMETA.*
|
|
||||||
24
Changes
24
Changes
@ -1,24 +0,0 @@
|
|||||||
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
|
|
||||||
47
MANIFEST
47
MANIFEST
@ -1,47 +0,0 @@
|
|||||||
.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
|
|
||||||
@ -1,19 +0,0 @@
|
|||||||
^\.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$
|
|
||||||
31
META.json
31
META.json
@ -1,31 +0,0 @@
|
|||||||
{
|
|
||||||
"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"
|
|
||||||
}
|
|
||||||
19
META.yml
19
META.yml
@ -1,19 +0,0 @@
|
|||||||
---
|
|
||||||
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
|
|
||||||
115
Makefile.PL
115
Makefile.PL
@ -1,115 +0,0 @@
|
|||||||
# -*- 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;
|
|
||||||
};
|
|
||||||
}
|
|
||||||
|
|
||||||
5
debian/changelog
vendored
5
debian/changelog
vendored
@ -1,5 +0,0 @@
|
|||||||
libarchive-sevenzip-perl (0.06-1) unstable; urgency=low
|
|
||||||
|
|
||||||
* Initial Release.
|
|
||||||
|
|
||||||
-- Mario Fetka <mario.fetka@gmail.com> Thu, 14 Sep 2017 11:27:23 +0200
|
|
||||||
1
debian/compat
vendored
1
debian/compat
vendored
@ -1 +0,0 @@
|
|||||||
9
|
|
||||||
16
debian/control
vendored
16
debian/control
vendored
@ -1,16 +0,0 @@
|
|||||||
Source: libarchive-sevenzip-perl
|
|
||||||
Section: perl
|
|
||||||
Priority: optional
|
|
||||||
Maintainer: Mario Fetka <mario.fetka@gmail.com>
|
|
||||||
Build-Depends: debhelper (>= 9), p7zip-full, libpath-class-perl, libarchive-zip-perl, unzip, zip
|
|
||||||
Build-Depends-Indep: perl
|
|
||||||
Standards-Version: 3.9.6
|
|
||||||
Homepage: https://metacpan.org/release/Archive-SevenZip
|
|
||||||
|
|
||||||
Package: libarchive-sevenzip-perl
|
|
||||||
Architecture: all
|
|
||||||
Depends: ${misc:Depends}, ${perl:Depends}, p7zip-full (>= 9.30), libpath-class-perl
|
|
||||||
Description: Read/write 7z , zip , ISO9960 and other archives
|
|
||||||
(no description was found)
|
|
||||||
.
|
|
||||||
This description was automagically extracted from the module by dh-make-perl.
|
|
||||||
36
debian/copyright
vendored
36
debian/copyright
vendored
@ -1,36 +0,0 @@
|
|||||||
Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
|
|
||||||
Source: https://metacpan.org/release/Archive-SevenZip
|
|
||||||
Upstream-Contact: Max Maischein <corion@cpan.org>
|
|
||||||
Upstream-Name: Archive-SevenZip
|
|
||||||
DISCLAIMER: This copyright info was automatically extracted
|
|
||||||
from the perl module. It may not be accurate, so you better
|
|
||||||
check the module sources in order to ensure the module for its
|
|
||||||
inclusion in Debian or for general legal information. Please,
|
|
||||||
if licensing information is incorrectly generated, file a bug
|
|
||||||
on dh-make-perl.
|
|
||||||
NOTE: Don't forget to remove this disclaimer once you are happy
|
|
||||||
with this file.
|
|
||||||
|
|
||||||
Files: *
|
|
||||||
Copyright: Max Maischein <corion@cpan.org>
|
|
||||||
License: Artistic or GPL-1+
|
|
||||||
|
|
||||||
Files: debian/*
|
|
||||||
Copyright: 2017, Mario Fetka <mario.fetka@gmail.com>
|
|
||||||
License: Artistic or GPL-1+
|
|
||||||
|
|
||||||
License: Artistic
|
|
||||||
This program is free software; you can redistribute it and/or modify
|
|
||||||
it under the terms of the Artistic License, which comes with Perl.
|
|
||||||
.
|
|
||||||
On Debian systems, the complete text of the Artistic License can be
|
|
||||||
found in `/usr/share/common-licenses/Artistic'.
|
|
||||||
|
|
||||||
License: GPL-1+
|
|
||||||
This program is free software; you can redistribute it and/or modify
|
|
||||||
it under the terms of the GNU General Public License as published by
|
|
||||||
the Free Software Foundation; either version 1, or (at your option)
|
|
||||||
any later version.
|
|
||||||
.
|
|
||||||
On Debian systems, the complete text of version 1 of the GNU General
|
|
||||||
Public License can be found in `/usr/share/common-licenses/GPL-1'.
|
|
||||||
4
debian/rules
vendored
4
debian/rules
vendored
@ -1,4 +0,0 @@
|
|||||||
#!/usr/bin/make -f
|
|
||||||
|
|
||||||
%:
|
|
||||||
dh $@
|
|
||||||
1
debian/source/format
vendored
1
debian/source/format
vendored
@ -1 +0,0 @@
|
|||||||
3.0 (quilt)
|
|
||||||
6
debian/upstream/metadata
vendored
6
debian/upstream/metadata
vendored
@ -1,6 +0,0 @@
|
|||||||
---
|
|
||||||
Archive: CPAN
|
|
||||||
Contact: Max Maischein <corion@cpan.org>
|
|
||||||
Name: Archive-SevenZip
|
|
||||||
Repository: git://github.com/Corion/archive-sevenzip.git
|
|
||||||
Repository-Browse: https://github.com/Corion/archive-sevenzip
|
|
||||||
2
debian/watch
vendored
2
debian/watch
vendored
@ -1,2 +0,0 @@
|
|||||||
version=3
|
|
||||||
https://metacpan.org/release/Archive-SevenZip .*/Archive-SevenZip-v?(\d[\d.-]*)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)$
|
|
||||||
@ -1,726 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,244 +0,0 @@
|
|||||||
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
|
|
||||||
@ -1,138 +0,0 @@
|
|||||||
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
|
|
||||||
BIN
libarchive-sevenzip-perl_0.06.orig.tar.gz.delta
Normal file
BIN
libarchive-sevenzip-perl_0.06.orig.tar.gz.delta
Normal file
Binary file not shown.
1
libarchive-sevenzip-perl_0.06.orig.tar.gz.id
Normal file
1
libarchive-sevenzip-perl_0.06.orig.tar.gz.id
Normal file
@ -0,0 +1 @@
|
|||||||
|
640ee202a19fdac432eb8d61ce6ee3d107d0eb6b
|
||||||
@ -1,57 +0,0 @@
|
|||||||
#!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" );
|
|
||||||
|
|
||||||
@ -1,38 +0,0 @@
|
|||||||
#!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";
|
|
||||||
|
|
||||||
381
t/02_main.t
381
t/02_main.t
@ -1,381 +0,0 @@
|
|||||||
#!/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);
|
|
||||||
#}
|
|
||||||
59
t/05_tree.t
59
t/05_tree.t
@ -1,59 +0,0 @@
|
|||||||
#!/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');
|
|
||||||
@ -1,59 +0,0 @@
|
|||||||
#!/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.
|
Before Width: | Height: | Size: 56 KiB |
Binary file not shown.
257
t/common.pm
257
t/common.pm
@ -1,257 +0,0 @@
|
|||||||
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.
BIN
t/data/chmod.zip
BIN
t/data/chmod.zip
Binary file not shown.
Binary file not shown.
BIN
t/data/crypt.zip
BIN
t/data/crypt.zip
Binary file not shown.
BIN
t/data/def.zip
BIN
t/data/def.zip
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -1 +0,0 @@
|
|||||||
abc
|
|
||||||
Binary file not shown.
BIN
t/data/jar.zip
BIN
t/data/jar.zip
Binary file not shown.
BIN
t/data/linux.zip
BIN
t/data/linux.zip
Binary file not shown.
@ -1,54 +0,0 @@
|
|||||||
#!/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";
|
|
||||||
|
|
||||||
BIN
t/data/perl.zip
BIN
t/data/perl.zip
Binary file not shown.
BIN
t/data/store.zip
BIN
t/data/store.zip
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
t/data/zip64.zip
BIN
t/data/zip64.zip
Binary file not shown.
@ -1,28 +0,0 @@
|
|||||||
#!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;
|
|
||||||
@ -1,43 +0,0 @@
|
|||||||
#!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'
|
|
||||||
);
|
|
||||||
@ -1,31 +0,0 @@
|
|||||||
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;
|
|
||||||
};
|
|
||||||
|
|
||||||
@ -1,17 +0,0 @@
|
|||||||
#!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();
|
|
||||||
}
|
|
||||||
36
xt/99-pod.t
36
xt/99-pod.t
@ -1,36 +0,0 @@
|
|||||||
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)$/;
|
|
||||||
}
|
|
||||||
47
xt/99-todo.t
47
xt/99-todo.t
@ -1,47 +0,0 @@
|
|||||||
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;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
@ -1,37 +0,0 @@
|
|||||||
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;
|
|
||||||
};
|
|
||||||
@ -1,51 +0,0 @@
|
|||||||
#!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
Block a user