summaryrefslogtreecommitdiff
path: root/gnu/usr.bin
diff options
context:
space:
mode:
authorTodd C. Miller <millert@cvs.openbsd.org>2010-09-24 14:49:07 +0000
committerTodd C. Miller <millert@cvs.openbsd.org>2010-09-24 14:49:07 +0000
commitf71c95b5031c3088ae3cd9d5dd30e7ec656a90a7 (patch)
tree8dce35ffcd4a360c13e9f9899f2901cfac9021ea /gnu/usr.bin
parent2b8edcc678d4399ef602e199f35685717f277627 (diff)
Perl 5.12.2 from CPAN
Diffstat (limited to 'gnu/usr.bin')
-rw-r--r--gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptar46
-rw-r--r--gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptardiff30
-rw-r--r--gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm354
-rw-r--r--gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm44
-rw-r--r--gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm117
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm705
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm372
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Author.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/CacheMgr.pm19
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Complete.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Debug.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm1464
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distroprefs.pm60
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/blocked_urllist.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm50
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm76
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP/netrc.pm5
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm695
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm339
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Index.pm151
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/LWP/UserAgent.pm93
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm491
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Module.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Nox.pm5
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm77
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm396
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm43
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Version.pm10
-rw-r--r--gnu/usr.bin/perl/cpan/CPAN/scripts/cpan71
-rw-r--r--gnu/usr.bin/perl/cpan/Digest-SHA/lib/Digest/SHA.pm376
-rw-r--r--gnu/usr.bin/perl/cpan/Digest-SHA/shasum315
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/bin/instmodsh8
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm65
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm1002
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm51
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm10
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm16
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm12
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm281
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm142
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm6
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod8
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm8
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm40
-rw-r--r--gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm1136
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm181
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/File/GlobMapper.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm22
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm21
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm4
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm209
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm443
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm191
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm133
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm237
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm192
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm806
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm34
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm41
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm6
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm121
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm8
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm153
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm180
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm333
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm190
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm148
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm137
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm149
-rw-r--r--gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm595
-rw-r--r--gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm1320
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/AnyDBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/Expire.pm7
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireFile.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireTest.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/NDBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/SDBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/Memoize/Memoize/Storable.pm2
-rw-r--r--gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm622
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/bin/prove211
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove.pm169
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State.pm93
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result.pm10
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Base.pm15
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Base.pm56
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Color.pm8
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm29
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm12
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File.pm10
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm13
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Session.pm15
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Harness.pm335
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Object.pm34
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser.pm423
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm16
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm58
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm25
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm20
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm45
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm20
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm334
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm11
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result.pm15
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm13
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm11
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm9
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm38
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm154
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm34
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm16
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Source.pm374
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm13
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm11
-rw-r--r--gnu/usr.bin/perl/cpan/Test-Harness/lib/Test/Harness.pm131
-rw-r--r--gnu/usr.bin/perl/cpan/Test/lib/Test.pm2
-rw-r--r--gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm34
-rw-r--r--gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm3
-rw-r--r--gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm2
-rw-r--r--gnu/usr.bin/perl/dist/IO/IO.pm6
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm8
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/File.pm13
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm42
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm10
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm6
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm35
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm62
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm57
-rw-r--r--gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm36
-rw-r--r--gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm435
-rw-r--r--gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm61
-rw-r--r--gnu/usr.bin/perl/dist/Module-CoreList/corelist226
-rw-r--r--gnu/usr.bin/perl/dist/Storable/Storable.pm159
-rw-r--r--gnu/usr.bin/perl/dist/base/lib/base.pm73
-rw-r--r--gnu/usr.bin/perl/dist/base/lib/fields.pm73
155 files changed, 6715 insertions, 13208 deletions
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptar b/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptar
index 0eaffa7ccb7..6a3c1bcd2ec 100644
--- a/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptar
+++ b/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptar
@@ -6,13 +6,8 @@ use Getopt::Std;
use Archive::Tar;
use Data::Dumper;
-# Allow historic support for dashless bundled options
-# tar cvf file.tar
-# is valid (GNU) tar style
-@ARGV && $ARGV[0] =~ m/^[DdcvzthxIC]+[fT]?$/ and
- unshift @ARGV, map { "-$_" } split m// => shift @ARGV;
my $opts = {};
-getopts('Ddcvzthxf:ICT:', $opts) or die usage();
+getopts('Ddcvzthxf:I', $opts) or die usage();
### show the help message ###
die usage() if $opts->{h};
@@ -33,21 +28,11 @@ my $verbose = $opts->{v} ? 1 : 0;
my $file = $opts->{f} ? $opts->{f} : 'default.tar';
my $tar = Archive::Tar->new();
+
if( $opts->{c} ) {
my @files;
- my @src = @ARGV;
- if( $opts->{T} ) {
- if( $opts->{T} eq "-" ) {
- chomp( @src = <STDIN> );
- } elsif( open my $fh, "<", $opts->{T} ) {
- chomp( @src = <$fh> );
- } else {
- die "$0: $opts->{T}: $!\n";
- }
- }
-
find( sub { push @files, $File::Find::name;
- print $File::Find::name.$/ if $verbose }, @src );
+ print $File::Find::name.$/ if $verbose }, @ARGV );
if ($file eq '-') {
use IO::Handle;
@@ -55,14 +40,8 @@ if( $opts->{c} ) {
$file->fdopen(fileno(STDOUT),"w");
}
- my $tar = Archive::Tar->new;
- $tar->add_files(@files);
- if( $opts->{C} ) {
- for my $f ($tar->get_files) {
- $f->mode($f->mode & ~022); # chmod go-w
- }
- }
- $tar->write($file, $compress);
+ Archive::Tar->create_archive( $file, $compress, @files );
+
} else {
if ($file eq '-') {
use IO::Handle;
@@ -74,13 +53,13 @@ if( $opts->{c} ) {
my $print = $verbose || $opts->{'t'} || 0;
my $iter = Archive::Tar->iter( $file );
-
+
while( my $f = $iter->() ) {
print $f->full_path . $/ if $print;
### data dumper output
print Dumper( $f ) if $opts->{'D'};
-
+
### extract it
$f->extract if $opts->{'x'};
}
@@ -102,8 +81,7 @@ sub usage {
=head1 SYNOPSIS
- ptar -c [-v] [-z] [-C] [-f ARCHIVE_FILE | -] FILE FILE ...
- ptar -c [-v] [-z] [-C] [-T index | -] [-f ARCHIVE_FILE | -]
+ ptar -c [-v] [-z] [-f ARCHIVE_FILE | -] FILE FILE ...
ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
ptar -t [-z] [-f ARCHIVE_FILE | -]
ptar -h
@@ -115,10 +93,8 @@ sub usage {
t List the contents of ARCHIVE_FILE or STDIN (-)
f Name of the ARCHIVE_FILE to use. Default is './default.tar'
z Read/Write zlib compressed ARCHIVE_FILE (not always available)
- v Print filenames as they are added or extracted from ARCHIVE_FILE
+ v Print filenames as they are added or extraced from ARCHIVE_FILE
h Prints this help message
- C CPAN mode - drop 022 from permissions
- T get names to create from file
=head1 SEE ALSO
@@ -129,10 +105,10 @@ sub usage {
### strip the pod directives
$usage =~ s/=pod\n//g;
$usage =~ s/=head1 //g;
-
+
### add some newlines
$usage .= $/.$/;
-
+
return $usage;
}
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptardiff b/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptardiff
index 5205d63c3fb..21e7d6cce59 100644
--- a/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptardiff
+++ b/gnu/usr.bin/perl/cpan/Archive-Tar/bin/ptardiff
@@ -21,12 +21,12 @@ my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
foreach my $file ( $tar->get_files ) {
next unless $file->is_file;
my $name = $file->name;
-
- diff( \($file->get_content), $name,
+
+ diff( \($file->get_content), $name,
{ FILENAME_A => $name,
MTIME_A => $file->mtime,
OUTPUT => \*STDOUT
- }
+ }
);
}
@@ -38,27 +38,27 @@ sub usage {
Usage: ptardiff ARCHIVE_FILE
ptardiff -h
-
+
ptardiff is a small program that diffs an extracted archive
against an unextracted one, using the perl module Archive::Tar.
-
- This effectively lets you view changes made to an archives contents.
-
+
+ This effectively lets you view changes made to an archives contents.
+
Provide the progam with an ARCHIVE_FILE and it will look up all
the files with in the archive, scan the current working directory
for a file with the name and diff it against the contents of the
archive.
-
+
Options:
h Prints this help message
Sample Usage:
- $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
$ vi Acme-Buffy-1.3/README
-
+
[...]
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
@@ -70,7 +70,7 @@ See Also:
Archive::Tar
] . $/;
-}
+}
@@ -82,9 +82,9 @@ ptardiff - program that diffs an extracted archive against an unextracted one
ptardiff is a small program that diffs an extracted archive
against an unextracted one, using the perl module Archive::Tar.
-
- This effectively lets you view changes made to an archives contents.
-
+
+ This effectively lets you view changes made to an archives contents.
+
Provide the progam with an ARCHIVE_FILE and it will look up all
the files with in the archive, scan the current working directory
for a file with the name and diff it against the contents of the
@@ -95,7 +95,7 @@ ptardiff - program that diffs an extracted archive against an unextracted one
ptardiff ARCHIVE_FILE
ptardiff -h
- $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
$ vi Acme-Buffy-1.3/README
[...]
$ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm
index 50afbb334b9..006edbd5c3e 100644
--- a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm
+++ b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm
@@ -23,7 +23,7 @@ require Exporter;
use strict;
use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
$DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS
- $INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT $RESOLVE_SYMLINK
+ $INSECURE_EXTRACT_MODE @ISA @EXPORT
];
@ISA = qw[Exporter];
@@ -31,14 +31,12 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD
$DEBUG = 0;
$WARN = 1;
$FOLLOW_SYMLINK = 0;
-$VERSION = "1.96";
+$VERSION = "1.54";
$CHOWN = 1;
$CHMOD = 1;
$SAME_PERMISSIONS = $> == 0 ? 1 : 0;
$DO_NOT_USE_PREFIX = 0;
$INSECURE_EXTRACT_MODE = 0;
-$ZERO_PAD_NUMBERS = 0;
-$RESOLVE_SYMLINK = $ENV{'PERL5_AT_RESOLVE_SYMLINK'} || 'speed';
BEGIN {
use Config;
@@ -69,9 +67,6 @@ Archive::Tar - module for manipulations of tar archives
$tar->add_data('file/baz.txt', 'This is the contents now');
$tar->rename('oldname', 'new/file/name');
- $tar->chown('/', 'root');
- $tar->chown('/', 'root:root');
- $tar->chmod('/tmp', '1777');
$tar->write('files.tar'); # plain tar
$tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed
@@ -172,14 +167,6 @@ very big archives, and are only interested in the first few files.
Can be set to a regular expression. Only files with names that match
the expression will be read.
-=item md5
-
-Set to 1 and the md5sum of files will be returned (instead of file data)
- my $iter = Archive::Tar->iter( $file, 1, {md5 => 1} );
- while( my $f = $iter->() ) {
- print $f->data . "\t" . $f->full_path . $/;
- }
-
=item extract
If set to true, immediately extract entries when reading them. This
@@ -224,15 +211,10 @@ sub read {
sub _get_handle {
my $self = shift;
my $file = shift; return unless defined $file;
+ return $file if ref $file;
my $compress = shift || 0;
my $mode = shift || READ_ONLY->( ZLIB ); # default to read only
- ### Check if file is a file handle or IO glob
- if ( ref $file ) {
- return $file if eval{ *$file{IO} };
- return $file if eval{ $file->isa(q{IO::Handle}) };
- $file = q{}.$file;
- }
### get a FH opened to the right class, so we can use it transparently
### throughout the program
@@ -318,8 +300,6 @@ sub _read_tar {
my $count = $opts->{limit} || 0;
my $filter = $opts->{filter};
- my $md5 = $opts->{md5} || 0; # cdrake
- my $filter_cb = $opts->{filter_cb};
my $extract = $opts->{extract} || 0;
### set a cap on the amount of files to extract ###
@@ -336,15 +316,7 @@ sub _read_tar {
LOOP:
while( $handle->read( $chunk, HEAD ) ) {
### IO::Zlib doesn't support this yet
- my $offset;
- if ( ref($handle) ne 'IO::Zlib' ) {
- local $@;
- $offset = eval { tell $handle } || 'unknown';
- $@ = '';
- }
- else {
- $offset = 'unknown';
- }
+ my $offset = eval { tell $handle } || 'unknown';
unless( $read++ ) {
my $gzip = GZIP_MAGIC_NUM;
@@ -352,7 +324,7 @@ sub _read_tar {
$self->_error( qq[Cannot read compressed format in tar-mode] );
return;
}
-
+
### size is < HEAD, which means a corrupted file, as the minimum
### length is _at least_ HEAD
if (length $chunk != HEAD) {
@@ -371,7 +343,7 @@ sub _read_tar {
### according to the posix spec, the last 12 bytes of the header are
### null bytes, to pad it to a 512 byte block. That means if these
- ### bytes are NOT null bytes, it's a corrupt header. See:
+ ### bytes are NOT null bytes, it's a corrrupt header. See:
### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx
### line 111
{ my $nulls = join '', "\0" x 12;
@@ -397,7 +369,7 @@ sub _read_tar {
}
### ignore labels:
- ### http://www.gnu.org/software/tar/manual/html_chapter/Media.html#SEC159
+ ### http://www.gnu.org/manual/tar/html_node/tar_139.html
next if $entry->is_label;
if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) {
@@ -418,65 +390,19 @@ sub _read_tar {
$data = $entry->get_content_by_ref;
- my $skip = 0;
- my $ctx; # cdrake
- ### skip this entry if we're filtering
-
- if($md5) { # cdrake
- $ctx = Digest::MD5->new; # cdrake
- $skip=5; # cdrake
-
- } elsif ($filter && $entry->name !~ $filter) {
- $skip = 1;
-
- ### skip this entry if it's a pax header. This is a special file added
- ### by, among others, git-generated tarballs. It holds comments and is
- ### not meant for extracting. See #38932: pax_global_header extracted
- } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) {
- $skip = 2;
- } elsif ($filter_cb && ! $filter_cb->($entry)) {
- $skip = 3;
- }
-
- if ($skip) {
- #
- # Since we're skipping, do not allocate memory for the
- # whole file. Read it 64 BLOCKS at a time. Do not
- # complete the skip yet because maybe what we read is a
- # longlink and it won't get skipped after all
- #
- my $amt = $block;
- my $fsz=$entry->size; # cdrake
- while ($amt > 0) {
- $$data = '';
- my $this = 64 * BLOCK;
- $this = $amt if $this > $amt;
- if( $handle->read( $$data, $this ) < $this ) {
- $self->_error( qq[Read error on tarfile (missing data) '].
- $entry->full_path ."' at offset $offset" );
- next LOOP;
- }
- $amt -= $this;
- $fsz -= $this; # cdrake
- substr ($$data, $fsz) = "" if ($fsz<0); # remove external junk prior to md5 # cdrake
- $ctx->add($$data) if($skip==5); # cdrake
- }
- $$data = $ctx->hexdigest if($skip==5 && !$entry->is_longlink && !$entry->is_unknown && !$entry->is_label ) ; # cdrake
- } else {
-
- ### just read everything into memory
- ### can't do lazy loading since IO::Zlib doesn't support 'seek'
- ### this is because Compress::Zlib doesn't support it =/
- ### this reads in the whole data in one read() call.
- if ( $handle->read( $$data, $block ) < $block ) {
- $self->_error( qq[Read error on tarfile (missing data) '].
+ ### just read everything into memory
+ ### can't do lazy loading since IO::Zlib doesn't support 'seek'
+ ### this is because Compress::Zlib doesn't support it =/
+ ### this reads in the whole data in one read() call.
+ if( $handle->read( $$data, $block ) < $block ) {
+ $self->_error( qq[Read error on tarfile (missing data) '].
$entry->full_path ."' at offset $offset" );
- next LOOP;
- }
- ### throw away trailing garbage ###
- substr ($$data, $entry->size) = "" if defined $$data;
+ next LOOP;
}
+ ### throw away trailing garbage ###
+ substr ($$data, $entry->size) = "" if defined $$data;
+
### part II of the @LongLink munging -- need to do /after/
### the checksum check.
if( $entry->is_longlink ) {
@@ -486,7 +412,7 @@ sub _read_tar {
### but that doesn't *always* happen.. so check if the last
### character is a control character, and if so remove it
### at any rate, we better remove that character here, or tests
- ### like 'eq' and hash lookups based on names will SO not work
+ ### like 'eq' and hashlook ups based on names will SO not work
### remove it by calculating the proper size, and then
### tossing out everything that's longer than that size.
@@ -516,24 +442,22 @@ sub _read_tar {
undef $real_name;
}
- if ($filter && $entry->name !~ $filter) {
- next LOOP;
-
- ### skip this entry if it's a pax header. This is a special file added
- ### by, among others, git-generated tarballs. It holds comments and is
- ### not meant for extracting. See #38932: pax_global_header extracted
- } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) {
- next LOOP;
- } elsif ($filter_cb && ! $filter_cb->($entry)) {
- next LOOP;
- }
-
- if ( $extract && !$entry->is_longlink
- && !$entry->is_unknown
- && !$entry->is_label ) {
- $self->_extract_file( $entry ) or return;
+ ### skip this entry if we're filtering
+ if ($filter && $entry->name !~ $filter) {
+ next LOOP;
+
+ ### skip this entry if it's a pax header. This is a special file added
+ ### by, among others, git-generated tarballs. It holds comments and is
+ ### not meant for extracting. See #38932: pax_global_header extracted
+ } elsif ( $entry->name eq PAX_HEADER ) {
+ next LOOP;
}
+ $self->_extract_file( $entry ) if $extract
+ && !$entry->is_longlink
+ && !$entry->is_unknown
+ && !$entry->is_label;
+
### Guard against tarfiles with garbage at the end
last LOOP if $entry->name eq '';
@@ -603,7 +527,7 @@ sub extract {
# use the speed optimization for all extracted files
local($self->{cwd}) = cwd() unless $self->{cwd};
- ### you requested the extraction of only certain files
+ ### you requested the extraction of only certian files
if( @args ) {
for my $file ( @args ) {
@@ -784,7 +708,7 @@ sub _extract_file {
my @cwd = File::Spec->splitdir( $cwd_dir );
push @cwd, $cwd_file if length $cwd_file;
- ### We need to pass '' as the last element to catpath. Craig Berry
+ ### We need to pass '' as the last elemant to catpath. Craig Berry
### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
### The root problem is that splitpath on UNIX always returns the
### final path element as a file even if it is a directory, and of
@@ -875,7 +799,7 @@ sub _extract_file {
$self->_error( qq[Could not update timestamp] );
}
- if( $CHOWN && CAN_CHOWN->() and not -l $full ) {
+ if( $CHOWN && CAN_CHOWN->() ) {
chown $entry->uid, $entry->gid, $full or
$self->_error( qq[Could not set uid/gid on '$full'] );
}
@@ -957,7 +881,7 @@ sub _extract_special_file_as_plain_file {
my $err;
TRY: {
- my $orig = $self->_find_entry( $entry->linkname, $entry );
+ my $orig = $self->_find_entry( $entry->linkname );
unless( $orig ) {
$err = qq[Could not find file '] . $entry->linkname .
@@ -966,7 +890,7 @@ sub _extract_special_file_as_plain_file {
}
### clone the entry, make it appear as a normal file ###
- my $clone = $orig->clone;
+ my $clone = $entry->clone;
$clone->_downgrade_to_plainfile;
$self->_extract_file( $clone, $file ) or last TRY;
@@ -1031,46 +955,10 @@ sub _find_entry {
### it's an object already
return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );
-seach_entry:
- if($self->_data){
- for my $entry ( @{$self->_data} ) {
- my $path = $entry->full_path;
- return $entry if $path eq $file;
- }
- }
-
- if($Archive::Tar::RESOLVE_SYMLINK!~/none/){
- if(my $link_entry = shift()){#fallback mode when symlinks are using relative notations ( ../a/./b/text.bin )
- $file = _symlinks_resolver( $link_entry->name, $file );
- goto seach_entry if $self->_data;
-
- #this will be slower than never, but won't failed!
-
- my $iterargs = $link_entry->{'_archive'};
- if($Archive::Tar::RESOLVE_SYMLINK=~/speed/ && @$iterargs==3){
- #faster but whole archive will be read in memory
- #read whole archive and share data
- my $archive = Archive::Tar->new;
- $archive->read( @$iterargs );
- push @$iterargs, $archive; #take a trace for destruction
- if($archive->_data){
- $self->_data( $archive->_data );
- goto seach_entry;
- }
- }#faster
-
- {#slower but lower memory usage
- # $iterargs = [$filename, $compressed, $opts];
- my $next = Archive::Tar->iter( @$iterargs );
- while(my $e = $next->()){
- if($e->full_path eq $file){
- undef $next;
- return $e;
- }
- }
- }#slower
- }
- }
+ for my $entry ( @{$self->_data} ) {
+ my $path = $entry->full_path;
+ return $entry if $path eq $file;
+ }
$self->_error( qq[No such file in archive: '$file'] );
return;
@@ -1147,45 +1035,6 @@ sub rename {
return $entry->rename( $new );
}
-=head2 $tar->chmod( $file, $mode )
-
-Change mode of $file to $mode.
-
-Returns true on success and false on failure.
-
-=cut
-
-sub chmod {
- my $self = shift;
- my $file = shift; return unless defined $file;
- my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
- my @args = ("$mode");
-
- my $entry = $self->_find_entry( $file ) or return;
- my $x = $entry->chmod( @args );
- return $x;
-}
-
-=head2 $tar->chown( $file, $uname [, $gname] )
-
-Change owner $file to $uname and $gname.
-
-Returns true on success and false on failure.
-
-=cut
-
-sub chown {
- my $self = shift;
- my $file = shift; return unless defined $file;
- my $uname = shift; return unless defined $uname;
- my @args = ($uname);
- push(@args, shift);
-
- my $entry = $self->_find_entry( $file ) or return;
- my $x = $entry->chown( @args );
- return $x;
-}
-
=head2 $tar->remove (@filenamelist)
Removes any entries with names matching any of the given filenames
@@ -1233,7 +1082,7 @@ GLOB reference).
The second argument is used to indicate compression. You can either
compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
to be the C<gzip> compression level (between 1 and 9), but the use of
-constants is preferred:
+constants is prefered:
# write a gzip compressed file
$tar->write( 'out.tgz', COMPRESS_GZIP );
@@ -1393,13 +1242,8 @@ sub write {
: $HAS_PERLIO ? $dummy
: do { seek $handle, 0, 0; local $/; <$handle> };
- ### make sure to close the handle if we created it
- if ( $file ne $handle ) {
- unless( close $handle ) {
- $self->_error( qq[Could not write tar] );
- return;
- }
- }
+ ### make sure to close the handle;
+ close $handle;
return $rv;
}
@@ -1414,7 +1258,7 @@ sub _format_tar_entry {
my $prefix = $entry->prefix; $prefix = '' unless defined $prefix;
### remove the prefix from the file name
- ### not sure if this is still needed --kane
+ ### not sure if this is still neeeded --kane
### no it's not -- Archive::Tar::File->_new_from_file will take care of
### this for us. Even worse, this would break if we tried to add a file
### like x/x.
@@ -1429,7 +1273,7 @@ sub _format_tar_entry {
my $l = PREFIX_LENGTH; # is ambiguous otherwise...
substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH;
- my $f1 = "%06o"; my $f2 = $ZERO_PAD_NUMBERS ? "%011o" : "%11o";
+ my $f1 = "%06o"; my $f2 = "%11o";
### this might be optimizable with a 'changed' flag in the file objects ###
my $tar = pack (
@@ -1452,7 +1296,6 @@ sub _format_tar_entry {
);
### add the checksum ###
- my $checksum_fmt = $ZERO_PAD_NUMBERS ? "%06o\0" : "%06o\0";
substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar));
return $tar;
@@ -1495,12 +1338,6 @@ sub add_files {
next;
}
- eval {
- if( utf8::is_utf8( $file )) {
- utf8::encode( $file );
- }
- };
-
unless( -e $file || -l $file ) {
$self->_error( qq[No such file: '$file'] );
next;
@@ -1532,8 +1369,8 @@ The following list of properties is supported: name, size, mtime
devmajor, devminor, prefix, type. (On MacOS, the file's path and
modification times are converted to Unix equivalents.)
-Valid values for the file type are the following constants defined by
-Archive::Tar::Constant:
+Valid values for the file type are the following constants defined in
+Archive::Tar::Constants:
=over 4
@@ -1590,7 +1427,7 @@ sub add_data {
=head2 $tar->error( [$BOOL] )
-Returns the current error string (usually, the last error reported).
+Returns the current errorstring (usually, the last error reported).
If a true value was specified, it will give the C<Carp::longmess>
equivalent of the error, in effect giving you a stacktrace.
@@ -1660,7 +1497,7 @@ To switch back to the default behaviour, use
and C<Archive::Tar> will call C<Cwd::cwd()> internally again.
-If you're using C<Archive::Tar>'s C<extract()> method, C<setcwd()> will
+If you're using C<Archive::Tar>'s C<exract()> method, C<setcwd()> will
be called for you.
=cut
@@ -1683,7 +1520,7 @@ reference to an open file handle (e.g. a GLOB reference).
The second argument is used to indicate compression. You can either
compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed
to be the C<gzip> compression level (between 1 and 9), but the use of
-constants is preferred:
+constants is prefered:
# write a gzip compressed file
Archive::Tar->create_archive( 'out.tgz', COMPRESS_GZIP, @filelist );
@@ -1755,7 +1592,7 @@ Example usage:
sub iter {
my $class = shift;
my $filename = shift or return;
- my $compressed = shift || 0;
+ my $compressed = shift or 0;
my $opts = shift || {};
### get a handle to read from.
@@ -1766,7 +1603,6 @@ sub iter {
) or return;
my @data;
- my $CONSTRUCT_ARGS = [ $filename, $compressed, $opts ];
return sub {
return shift(@data) if @data; # more than one file returned?
return unless $handle; # handle exhausted?
@@ -1774,25 +1610,12 @@ sub iter {
### read data, should only return file
my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 });
@data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY';
- if($Archive::Tar::RESOLVE_SYMLINK!~/none/){
- foreach(@data){
- #may refine this heuristic for ON_UNIX?
- if($_->linkname){
- #is there a better slot to store/share it ?
- $_->{'_archive'} = $CONSTRUCT_ARGS;
- }
- }
- }
### return one piece of data
return shift(@data) if @data;
### data is exhausted, free the filehandle
undef $handle;
- if(@$CONSTRUCT_ARGS == 4){
- #free archive in memory
- undef $CONSTRUCT_ARGS->[-1];
- }
return;
};
}
@@ -1807,7 +1630,7 @@ If C<list_archive()> is passed an array reference as its third
argument it returns a list of hash references containing the requested
properties of each file. The following list of properties is
supported: full_path, name, size, mtime (last modified date), mode,
-uid, gid, linkname, uname, gname, devmajor, devminor, prefix, type.
+uid, gid, linkname, uname, gname, devmajor, devminor, prefix.
See C<Archive::Tar::File> for details about supported properties.
@@ -1916,32 +1739,6 @@ sub no_string_support {
croak("You have to install IO::String to support writing archives to strings");
}
-sub _symlinks_resolver{
- my ($src, $trg) = @_;
- my @src = split /[\/\\]/, $src;
- my @trg = split /[\/\\]/, $trg;
- pop @src; #strip out current object name
- if(@trg and $trg[0] eq ''){
- shift @trg;
- #restart path from scratch
- @src = ( );
- }
- foreach my $part ( @trg ){
- next if $part eq '.'; #ignore current
- if($part eq '..'){
- #got to parent
- pop @src;
- }
- else{
- #append it
- push @src, $part;
- }
- }
- my $path = join('/', @src);
- warn "_symlinks_resolver('$src','$trg') = $path" if $DEBUG;
- return $path;
-}
-
1;
__END__
@@ -2077,37 +1874,6 @@ your perl to be able to write stringified archives.
Don't change this variable unless you B<really> know what you're
doing.
-=head2 $Archive::Tar::ZERO_PAD_NUMBERS
-
-This variable holds a boolean indicating if we will create
-zero padded numbers for C<size>, C<mtime> and C<checksum>.
-The default is C<0>, indicating that we will create space padded
-numbers. Added for compatibility with C<busybox> implementations.
-
-=head2 Tuning the way RESOLVE_SYMLINK will works
-
- You can tune the behaviour by setting the $Archive::Tar::RESOLVE_SYMLINK variable,
- or $ENV{PERL5_AT_RESOLVE_SYMLINK} before loading the module Archive::Tar.
-
- Values can be one of the following:
-
- none
- Disable this mechanism and failed as it was in previous version (<1.88)
-
- speed (default)
- If you prefer speed
- this will read again the whole archive using read() so all entries
- will be available
-
- memory
- If you prefer memory
-
- Limitation
-
- It won't work for terminal, pipe or sockets or every non seekable source.
-
-=cut
-
=head1 FAQ
=over 4
@@ -2166,7 +1932,7 @@ the extraction of this particular item didn't work.
By default, C<Archive::Tar> is in a completely POSIX-compatible
mode, which uses the POSIX-specification of C<tar> to store files.
-For paths greater than 100 characters, this is done using the
+For paths greather than 100 characters, this is done using the
C<POSIX header prefix>. Non-POSIX-compatible clients may not support
this part of the specification, and may only support the C<GNU Extended
Header> functionality. To facilitate those clients, you can set the
@@ -2288,7 +2054,7 @@ encoded in a different way.
=head1 CAVEATS
-The AIX tar does not fill all unused space in the tar archive with 0x00.
+The AIX tar does not fill all unused space in the tar archive with 0x00.
This sometimes leads to warning messages from C<Archive::Tar>.
Invalid header block at offset nnn
@@ -2300,14 +2066,14 @@ of AIX, all of which should be coming out in the 4th quarter of 2009:
AIX 5.3 TL8 SP8
AIX 5.3 TL9 SP5
AIX 5.3 TL10 SP2
-
+
AIX 6.1 TL0 SP11
AIX 6.1 TL1 SP7
AIX 6.1 TL2 SP6
AIX 6.1 TL3 SP3
-The IBM APAR number for this problem is IZ50240 (Reported component ID:
-5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
+The IBM APAR number for this problem is IZ50240 (Reported component ID:
+5765G0300 / AIX 5.3). It is possible to get an ifix for that problem.
If you need an ifix please contact your local IBM AIX support.
=head1 TODO
@@ -2341,9 +2107,9 @@ to an uploaded file, which might be a compressed archive.
C<http://www.gnu.org/software/tar/manual/tar.html>
-=item The PAX format specification
+=item The PAX format specication
-The specification which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
+The specifcation which tar derives from; C< http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html>
=item A comparison of GNU and POSIX tar standards; C<http://www.delorie.com/gnu/docs/tar/tar_114.html>
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
index 957ac278adc..aef1d623fa8 100644
--- a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
+++ b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm
@@ -2,14 +2,15 @@ package Archive::Tar::Constant;
BEGIN {
require Exporter;
-
- $VERSION = '1.96';
+
+ $VERSION = '0.02';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
}
-@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
+use Package::Constants;
+@EXPORT = Package::Constants->list( __PACKAGE__ );
use constant FILE => 0;
use constant HARDLINK => 1;
@@ -50,12 +51,12 @@ use constant MODE => do { 0666 & (0777 & ~umask) };
use constant STRIP_MODE => sub { shift() & 0777 };
use constant CHECK_SUM => " ";
-use constant UNPACK => 'A100 A8 A8 A8 a12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
+use constant UNPACK => 'A100 A8 A8 A8 A12 A12 A8 A1 A100 A6 A2 A32 A32 A8 A8 A155 x12';
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
use constant NAME_LENGTH => 100;
use constant PREFIX_LENGTH => 155;
-use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
+use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0;
use constant MAGIC => "ustar";
use constant TAR_VERSION => "00";
use constant LONGLINK_NAME => '././@LongLink';
@@ -64,14 +65,14 @@ use constant PAX_HEADER => 'pax_global_header';
### allow ZLIB to be turned off using ENV: DEBUG only
use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
eval { require IO::Zlib };
- $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
+ $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
};
- ### allow BZIP to be turned off using ENV: DEBUG only
+ ### allow BZIP to be turned off using ENV: DEBUG only
use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
eval { require IO::Uncompress::Bunzip2;
require IO::Compress::Bzip2; };
- $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
+ $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
};
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
@@ -80,31 +81,6 @@ use constant BZIP_MAGIC_NUM => qr/^BZh\d/;
use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
-use constant ON_VMS => $^O eq 'VMS';
-
-sub _list_consts {
- my $class = shift;
- my $pkg = shift;
- return unless defined $pkg; # some joker might use '0' as a pkg...
-
- my @rv;
- { no strict 'refs';
- my $stash = $pkg . '::';
-
- for my $name (sort keys %$stash ) {
-
- ### is it a subentry?
- my $sub = $pkg->can( $name );
- next unless defined $sub;
-
- next unless defined prototype($sub) and
- not length prototype($sub);
-
- push @rv, $name;
- }
- }
-
- return sort @rv;
-}
+use constant ON_VMS => $^O eq 'VMS';
1;
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm
index 39fca623fab..0815bb67620 100644
--- a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm
+++ b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm
@@ -13,27 +13,26 @@ use Archive::Tar::Constant;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
-$VERSION = '1.96';
+$VERSION = '0.02';
### set value to 1 to oct() it during the unpack ###
-
my $tmpl = [
- name => 0, # string A100
- mode => 1, # octal A8
- uid => 1, # octal A8
- gid => 1, # octal A8
- size => 0, # octal # cdrake - not *always* octal.. A12
- mtime => 1, # octal A12
- chksum => 1, # octal A8
- type => 0, # character A1
- linkname => 0, # string A100
- magic => 0, # string A6
- version => 0, # 2 bytes A2
- uname => 0, # string A32
- gname => 0, # string A32
- devmajor => 1, # octal A8
- devminor => 1, # octal A8
- prefix => 0, # A155 x 12
+ name => 0, # string
+ mode => 1, # octal
+ uid => 1, # octal
+ gid => 1, # octal
+ size => 1, # octal
+ mtime => 1, # octal
+ chksum => 1, # octal
+ type => 0, # character
+ linkname => 0, # string
+ magic => 0, # string
+ version => 0, # 2 bytes
+ uname => 0, # string
+ gname => 0, # string
+ devmajor => 1, # octal
+ devminor => 1, # octal
+ prefix => 0,
### end UNPACK items ###
raw => 0, # the raw data chunk
@@ -215,20 +214,8 @@ sub _new_from_chunk {
### makes it start at 0 actually... :) ###
my $i = -1;
my %entry = map {
- my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
- ($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
- $s=> $v ? oct $_ : $_ # cdrake
- # $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
- } unpack( UNPACK, $chunk ); # cdrake
- # } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
-
-
- if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
- my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake
- } else { # cdrake
- ($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
- } # cdrake
-
+ $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_
+ } map { /^([^\0]*)/ } unpack( UNPACK, $chunk );
my $obj = bless { %entry, %args }, $class;
@@ -249,23 +236,23 @@ sub _new_from_chunk {
sub _new_from_file {
my $class = shift;
- my $path = shift;
-
+ my $path = shift;
+
### path has to at least exist
return unless defined $path;
-
+
my $type = __PACKAGE__->_filetype($path);
my $data = '';
- READ: {
+ READ: {
unless ($type == DIR ) {
my $fh = IO::File->new;
-
+
unless( $fh->open($path) ) {
### dangling symlinks are fine, stop reading but continue
### creating the object
last READ if $type == SYMLINK;
-
+
### otherwise, return from this function --
### anything that's *not* a symlink should be
### resolvable
@@ -418,7 +405,7 @@ sub _prefix_and_file {
sub _filetype {
my $self = shift;
my $file = shift;
-
+
return unless defined $file;
return SYMLINK if (-l $file); # Symlink
@@ -455,7 +442,7 @@ sub _downgrade_to_plainfile {
=head2 $bool = $file->extract( [ $alternative_name ] )
-Extract this object, optionally to an alternative name.
+Extract this object, optionally to an alternative name.
See C<< Archive::Tar->extract_file >> for details.
@@ -465,9 +452,9 @@ Returns true on success and false on failure.
sub extract {
my $self = shift;
-
+
local $Carp::CarpLevel += 1;
-
+
return Archive::Tar->_extract_file( $self, @_ );
}
@@ -481,7 +468,7 @@ concatenation of the C<prefix> and C<name> fields.
sub full_path {
my $self = shift;
- ### if prefix field is empty
+ ### if prefix field is emtpy
return $self->name unless defined $self->prefix and length $self->prefix;
### or otherwise, catfile'd
@@ -589,7 +576,7 @@ Returns true on success and false on failure.
sub rename {
my $self = shift;
my $path = shift;
-
+
return unless defined $path;
my ($prefix,$file) = $self->_prefix_and_file( $path );
@@ -600,48 +587,6 @@ sub rename {
return 1;
}
-=head2 $bool = $file->chmod $mode)
-
-Change mode of $file to $mode. The mode can be a string or a number
-which is interpreted as octal whether or not a leading 0 is given.
-
-Returns true on success and false on failure.
-
-=cut
-
-sub chmod {
- my $self = shift;
- my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
- $self->{mode} = oct($mode);
- return 1;
-}
-
-=head2 $bool = $file->chown( $user [, $group])
-
-Change owner of $file to $user. If a $group is given that is changed
-as well. You can also pass a single parameter with a colon separating the
-use and group as in 'root:wheel'.
-
-Returns true on success and false on failure.
-
-=cut
-
-sub chown {
- my $self = shift;
- my $uname = shift;
- return unless defined $uname;
- my $gname;
- if (-1 != index($uname, ':')) {
- ($uname, $gname) = split(/:/, $uname);
- } else {
- $gname = shift if @_ > 0;
- }
-
- $self->uname( $uname );
- $self->gname( $gname ) if $gname;
- return 1;
-}
-
=head1 Convenience methods
To quickly check the type of a C<Archive::Tar::File> object, you can
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm
index b548bcc0ae6..cfc12908e52 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm
@@ -1,12 +1,9 @@
package App::Cpan;
-
use strict;
use warnings;
use vars qw($VERSION);
-use if $] < 5.008 => "IO::Scalar";
-
-$VERSION = '1.62';
+$VERSION = '1.5701';
=head1 NAME
@@ -18,20 +15,20 @@ App::Cpan - easily interact with CPAN from the command line
cpan module_name [ module_name ... ]
# with switches, installs modules with extra behavior
- cpan [-cfFimtTw] module_name [ module_name ... ]
+ cpan [-cfFimt] module_name [ module_name ... ]
# use local::lib
- cpan -I module_name [ module_name ... ]
-
+ cpan -l module_name [ module_name ... ]
+
# with just the dot, install from the distribution in the
# current directory
cpan .
-
+
# without arguments, starts CPAN.pm shell
cpan
# without arguments, but some switches
- cpan [-ahpruvACDLOP]
+ cpan [-ahruvACDLO]
=head1 DESCRIPTION
@@ -76,7 +73,7 @@ to install a module even if its tests fail. When you use this option,
=item -F
-Turn off CPAN.pm's attempts to lock anything. You should be careful with
+Turn off CPAN.pm's attempts to lock anything. You should be careful with
this since you might end up with multiple scripts trying to muck in the
same directory. This isn't so much of a concern if you're loading a special
config with C<-j>, and that config sets up its own work directories.
@@ -103,18 +100,12 @@ of the other options and arguments.
=item -i
-Install the specified modules. With no other switches, this switch
-is implied.
-
-=item -I
-
-Load C<local::lib> (think like C<-I> for loading lib paths). Too bad
-C<-l> was already taken.
+Install the specified modules.
=item -j Config.pm
Load the file that has the CPAN configuration data. This should have the
-same format as the standard F<CPAN/Config.pm> file, which defines
+same format as the standard F<CPAN/Config.pm> file, which defines
C<$CPAN::Config> as an anonymous hash.
=item -J
@@ -125,7 +116,7 @@ for a new, custom configuration.
=item -l
-List all installed modules with their versions
+Use C<local::lib>.
=item -L author [ author ... ]
@@ -135,33 +126,17 @@ List the modules by the specified authors.
Make the specified modules.
-=item -n
-
-Do a dry run, but don't actually install anything. (unimplemented)
-
=item -O
Show the out-of-date modules.
-=item -p
-
-Ping the configured mirrors
-
-=item -P
-
-Find the best mirrors you could be using (but doesn't configure them just yet)
-
-=item -r
-
-Recompiles dynamically loaded modules with CPAN::Shell->recompile.
-
=item -t
Run a `make test` on the specified modules.
-=item -T
+=item -r
-Do not test modules. Simply install them.
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
=item -u
@@ -172,17 +147,6 @@ so keep a backup.
Print the script version and CPAN.pm version then exit.
-=item -V
-
-Print detailed information about the cpan client.
-
-=item -w
-
-UNIMPLEMENTED
-
-Turn on cpan warnings. This checks various things, like directory permissions,
-and tells you about problems you might have.
-
=back
=head2 Examples
@@ -217,35 +181,35 @@ and tells you about problems you might have.
use autouse Carp => qw(carp croak cluck);
use CPAN ();
-use Config;
use autouse Cwd => qw(cwd);
use autouse 'Data::Dumper' => qw(Dumper);
use File::Spec::Functions;
use File::Basename;
+
use Getopt::Std;
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# Internal constants
use constant TRUE => 1;
use constant FALSE => 0;
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# The return values
-use constant HEY_IT_WORKED => 0;
+use constant HEY_IT_WORKED => 0;
use constant I_DONT_KNOW_WHAT_HAPPENED => 1; # 0b0000_0001
use constant ITS_NOT_MY_FAULT => 2;
use constant THE_PROGRAMMERS_AN_IDIOT => 4;
use constant A_MODULE_FAILED_TO_INSTALL => 8;
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# set up the order of options that we layer over CPAN::Shell
BEGIN { # most of this should be in methods
use vars qw( @META_OPTIONS $Default %CPAN_METHODS @CPAN_OPTIONS @option_order
%Method_table %Method_table_index );
-
-@META_OPTIONS = qw( h v V I g G C A D O l L a r p P j: J w T);
+
+@META_OPTIONS = qw( h v g G C A D O l L a r j: J );
$Default = 'default';
@@ -263,7 +227,7 @@ $Default = 'default';
@option_order = ( @META_OPTIONS, @CPAN_OPTIONS );
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# map switches to the subroutines in this script, along with other information.
# use this stuff instead of hard-coded indices and values
sub NO_ARGS () { 0 }
@@ -276,31 +240,25 @@ sub GOOD_EXIT () { 0 }
# options that do their thing first, then exit
h => [ \&_print_help, NO_ARGS, GOOD_EXIT, 'Printing help' ],
v => [ \&_print_version, NO_ARGS, GOOD_EXIT, 'Printing version' ],
- V => [ \&_print_details, NO_ARGS, GOOD_EXIT, 'Printing detailed version' ],
# options that affect other options
j => [ \&_load_config, ARGS, GOOD_EXIT, 'Use specified config file' ],
J => [ \&_dump_config, NO_ARGS, GOOD_EXIT, 'Dump configuration to stdout' ],
F => [ \&_lock_lobotomy, NO_ARGS, GOOD_EXIT, 'Turn off CPAN.pm lock files' ],
- I => [ \&_load_local_lib, NO_ARGS, GOOD_EXIT, 'Loading local::lib' ],
- w => [ \&_turn_on_warnings, NO_ARGS, GOOD_EXIT, 'Turning on warnings' ],
- T => [ \&_turn_off_testing, NO_ARGS, GOOD_EXIT, 'Turning off testing' ],
# options that do their one thing
g => [ \&_download, NO_ARGS, GOOD_EXIT, 'Download the latest distro' ],
G => [ \&_gitify, NO_ARGS, GOOD_EXIT, 'Down and gitify the latest distro' ],
-
+
C => [ \&_show_Changes, ARGS, GOOD_EXIT, 'Showing Changes file' ],
A => [ \&_show_Author, ARGS, GOOD_EXIT, 'Showing Author' ],
D => [ \&_show_Details, ARGS, GOOD_EXIT, 'Showing Details' ],
O => [ \&_show_out_of_date, NO_ARGS, GOOD_EXIT, 'Showing Out of date' ],
+
l => [ \&_list_all_mods, NO_ARGS, GOOD_EXIT, 'Listing all modules' ],
L => [ \&_show_author_mods, ARGS, GOOD_EXIT, 'Showing author mods' ],
a => [ \&_create_autobundle, NO_ARGS, GOOD_EXIT, 'Creating autobundle' ],
- p => [ \&_ping_mirrors, NO_ARGS, GOOD_EXIT, 'Pinging mirrors' ],
- P => [ \&_find_good_mirrors, NO_ARGS, GOOD_EXIT, 'Finding good mirrors' ],
-
r => [ \&_recompile, NO_ARGS, GOOD_EXIT, 'Recompiling' ],
u => [ \&_upgrade, NO_ARGS, GOOD_EXIT, 'Running `make test`' ],
@@ -309,6 +267,7 @@ sub GOOD_EXIT () { 0 }
i => [ \&_default, ARGS, GOOD_EXIT, 'Running `make install`' ],
'm' => [ \&_default, ARGS, GOOD_EXIT, 'Running `make`' ],
t => [ \&_default, ARGS, GOOD_EXIT, 'Running `make test`' ],
+
);
%Method_table_index = (
@@ -319,8 +278,7 @@ sub GOOD_EXIT () { 0 }
);
}
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# finally, do some argument processing
sub _stupid_interface_hack_for_non_rtfmers
@@ -328,19 +286,17 @@ sub _stupid_interface_hack_for_non_rtfmers
no warnings 'uninitialized';
shift @ARGV if( $ARGV[0] eq 'install' and @ARGV > 1 )
}
-
+
sub _process_options
{
my %options;
-
- push @ARGV, grep $_, split /\s+/, $ENV{CPAN_OPTS} || '';
-
+
# if no arguments, just drop into the shell
if( 0 == @ARGV ) { CPAN::shell(); exit 0 }
else
{
Getopt::Std::getopts(
- join( '', @option_order ), \%options );
+ join( '', @option_order ), \%options );
\%options;
}
}
@@ -348,7 +304,7 @@ sub _process_options
sub _process_setup_options
{
my( $class, $options ) = @_;
-
+
if( $options->{j} )
{
$Method_table{j}[ $Method_table_index{code} ]->( $options->{j} );
@@ -357,36 +313,22 @@ sub _process_setup_options
else
{
# this is what CPAN.pm would do otherwise
- local $CPAN::Be_Silent = 1;
CPAN::HandleConfig->load(
- # be_silent => 1, deprecated
+ # be_silent => 1, # candidate to be ripped out forever
write_file => 0,
);
}
-
- foreach my $o ( qw(F I w T) )
+
+ if( $options->{F} )
{
- next unless exists $options->{$o};
- $Method_table{$o}[ $Method_table_index{code} ]->( $options->{$o} );
- delete $options->{$o};
- }
-
- if( $options->{o} )
- {
- my @pairs = map { [ split /=/, $_, 2 ] } split /,/, $options->{o};
- foreach my $pair ( @pairs )
- {
- my( $setting, $value ) = @$pair;
- $CPAN::Config->{$setting} = $value;
- # $logger->debug( "Setting [$setting] to [$value]" );
- }
- delete $options->{o};
+ $Method_table{F}[ $Method_table_index{code} ]->( $options->{F} );
+ delete $options->{F};
}
my $option_count = grep { $options->{$_} } @option_order;
no warnings 'uninitialized';
$option_count -= $options->{'f'}; # don't count force
-
+
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# if there are no options, set -i (this line fixes RT ticket 16915)
$options->{i}++ unless $option_count;
@@ -397,7 +339,7 @@ sub _process_setup_options
Just do it.
-The C<run> method returns 0 on success and a positive number on
+The C<run> method returns 0 on success and a postive number on
failure. See the section on EXIT CODES for details on the values.
=cut
@@ -425,10 +367,10 @@ sub run
$class->_process_setup_options( $options );
OPTION: foreach my $option ( @option_order )
- {
+ {
next unless $options->{$option};
- my( $sub, $takes_args, $description ) =
+ my( $sub, $takes_args, $description ) =
map { $Method_table{$option}[ $Method_table_index{$_} ] }
qw( code takes_args );
@@ -440,7 +382,7 @@ sub run
$logger->info( "$description -- ignoring other arguments" )
if( @ARGV && ! $takes_args );
-
+
$return_value = $sub->( \ @ARGV, $options );
last;
@@ -450,44 +392,43 @@ sub run
}
{
-package
- Local::Null::Logger; # hide from PAUSE
+package Local::Null::Logger;
sub new { bless \ my $x, $_[0] }
-sub AUTOLOAD { 1 }
+sub AUTOLOAD { shift; print "NullLogger: ", @_, $/ if $ENV{CPAN_NULL_LOGGER} }
sub DESTROY { 1 }
}
sub _init_logger
{
my $log4perl_loaded = eval "require Log::Log4perl; 1";
-
+
unless( $log4perl_loaded )
{
$logger = Local::Null::Logger->new;
return $logger;
}
-
+
my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO';
-
+
Log::Log4perl::init( \ <<"HERE" );
log4perl.rootLogger=$LEVEL, A1
log4perl.appender.A1=Log::Log4perl::Appender::Screen
log4perl.appender.A1.layout=PatternLayout
log4perl.appender.A1.layout.ConversionPattern=%m%n
HERE
-
+
$logger = Log::Log4perl->get_logger( 'App::Cpan' );
}
-
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
- # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _default
{
my( $args, $options ) = @_;
-
+
my $switch = '';
# choose the option that we're going to use
@@ -517,12 +458,12 @@ sub _default
if( $options->{f} ) { sub { CPAN::Shell->force( $method, @_ ) } }
else { sub { CPAN::Shell->$method( @_ ) } }
};
-
+
# How do I handle exit codes for multiple arguments?
my $errors = 0;
-
- foreach my $arg ( @$args )
- {
+
+ foreach my $arg ( @$args )
+ {
_clear_cpanpm_output();
$action->( $arg );
@@ -532,26 +473,25 @@ sub _default
$errors ? I_DONT_KNOW_WHAT_HAPPENED : HEY_IT_WORKED;
}
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
=for comment
-CPAN.pm sends all the good stuff either to STDOUT, or to a temp
-file if $CPAN::Be_Silent is set. I have to intercept that output
-so I can find out what happened.
+CPAN.pm sends all the good stuff either to STDOUT. I have to intercept
+that output so I can find out what happened.
=cut
-BEGIN {
+{
my $scalar = '';
sub _hook_into_CPANpm_report
{
no warnings 'redefine';
-
+
*CPAN::Shell::myprint = sub {
my($self,$what) = @_;
- $scalar .= $what;
+ $scalar .= $what if defined $what;
$self->print_ornamented($what,
$CPAN::Config->{colorize_print}||'bold blue on_white',
);
@@ -559,18 +499,19 @@ sub _hook_into_CPANpm_report
*CPAN::Shell::mywarn = sub {
my($self,$what) = @_;
- $scalar .= $what;
- $self->print_ornamented($what,
+ $scalar .= $what if defined $what;
+ $self->print_ornamented($what,
$CPAN::Config->{colorize_warn}||'bold red on_white'
);
};
}
-
+
sub _clear_cpanpm_output { $scalar = '' }
-
+
sub _get_cpanpm_output { $scalar }
+BEGIN {
my @skip_lines = (
qr/^\QWarning \(usually harmless\)/,
qr/\bwill not store persistent state\b/,
@@ -580,15 +521,10 @@ my @skip_lines = (
sub _get_cpanpm_last_line
{
- my $fh;
- if ($] < 5.008) {
- $fh = IO::Scalar->new(\ $scalar);
- } else {
- eval q{open $fh, "<", \\ $scalar;};
- }
-
+ open my($fh), "<", \ $scalar;
+
my @lines = <$fh>;
-
+
# This is a bit ugly. Once we examine a line, we have to
# examine the line before it and go through all of the same
# regexes. I could do something fancy, but this works.
@@ -601,10 +537,10 @@ sub _get_cpanpm_last_line
redo REGEXES; # we have to go through all of them for every line!
}
}
- }
-
+ }
+
$logger->debug( "Last interesting line of CPAN.pm output is:\n\t$lines[-1]" );
-
+
$lines[-1];
}
}
@@ -612,305 +548,53 @@ sub _get_cpanpm_last_line
BEGIN {
my $epic_fail_words = join '|',
qw( Error stop(?:ping)? problems force not unsupported fail(?:ed)? );
-
+
sub _cpanpm_output_indicates_failure
{
my $last_line = _get_cpanpm_last_line();
-
+
my $result = $last_line =~ /\b(?:$epic_fail_words)\b/i;
$result || ();
}
}
-
+
sub _cpanpm_output_indicates_success
{
my $last_line = _get_cpanpm_last_line();
-
+
my $result = $last_line =~ /\b(?:\s+-- OK|PASS)\b/;
$result || ();
}
-
+
sub _cpanpm_output_is_vague
{
- return FALSE if
- _cpanpm_output_indicates_failure() ||
+ return FALSE if
+ _cpanpm_output_indicates_failure() ||
_cpanpm_output_indicates_success();
return TRUE;
}
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
-sub _turn_on_warnings {
- carp "Warnings are implemented yet";
- return HEY_IT_WORKED;
- }
-
-sub _turn_off_testing {
- $logger->debug( 'Trusting test report history' );
- $CPAN::Config->{trust_test_report_history} = 1;
- return HEY_IT_WORKED;
- }
+}
-# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub _print_help
{
$logger->info( "Use perldoc to read the documentation" );
exec "perldoc $0";
}
-
-sub _print_version # -v
+
+sub _print_version
{
- $logger->info(
+ $logger->info(
"$0 script version $VERSION, CPAN.pm version " . CPAN->VERSION );
return HEY_IT_WORKED;
}
-
-sub _print_details # -V
- {
- _print_version();
-
- _check_install_dirs();
-
- $logger->info( '-' x 50 . "\nChecking configured mirrors..." );
- foreach my $mirror ( @{ $CPAN::Config->{urllist} } ) {
- _print_ping_report( $mirror );
- }
-
- $logger->info( '-' x 50 . "\nChecking for faster mirrors..." );
-
- {
- require CPAN::Mirrors;
-
- if ( $CPAN::Config->{connect_to_internet_ok} ) {
- $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
- eval { CPAN::FTP->localize('MIRRORED.BY',File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY'),3,1) }
- or $CPAN::Frontend->mywarn(<<'HERE');
-We failed to get a copy of the mirror list from the Internet.
-You will need to provide CPAN mirror URLs yourself.
-HERE
- $CPAN::Frontend->myprint("\n");
- }
-
- my $mirrors = CPAN::Mirrors->new( );
- $mirrors->parse_mirrored_by( File::Spec->catfile($CPAN::Config->{keep_source_where},'MIRRORED.BY') );
- my @continents = $mirrors->find_best_continents;
-
- my @mirrors = $mirrors->get_mirrors_by_continents( $continents[0] );
- my @timings = $mirrors->get_mirrors_timings( \@mirrors );
-
- foreach my $timing ( @timings ) {
- $logger->info( sprintf "%s (%0.2f ms)",
- $timing->hostname, $timing->rtt );
- }
- }
-
- return HEY_IT_WORKED;
- }
-
-sub _check_install_dirs
- {
- my $makepl_arg = $CPAN::Config->{makepl_arg};
- my $mbuildpl_arg = $CPAN::Config->{mbuildpl_arg};
-
- my @custom_dirs;
- # PERL_MM_OPT
- push @custom_dirs,
- $makepl_arg =~ m/INSTALL_BASE\s*=\s*(\S+)/g,
- $mbuildpl_arg =~ m/--install_base\s*=\s*(\S+)/g;
-
- if( @custom_dirs ) {
- foreach my $dir ( @custom_dirs ) {
- _print_inc_dir_report( $dir );
- }
- }
-
- # XXX: also need to check makepl_args, etc
-
- my @checks = (
- [ 'core', [ grep $_, @Config{qw(installprivlib installarchlib)} ] ],
- [ 'vendor', [ grep $_, @Config{qw(installvendorlib installvendorarch)} ] ],
- [ 'site', [ grep $_, @Config{qw(installsitelib installsitearch)} ] ],
- [ 'PERL5LIB', _split_paths( $ENV{PERL5LIB} ) ],
- [ 'PERLLIB', _split_paths( $ENV{PERLLIB} ) ],
- );
-
- $logger->info( '-' x 50 . "\nChecking install dirs..." );
- foreach my $tuple ( @checks ) {
- my( $label ) = $tuple->[0];
-
- $logger->info( "Checking $label" );
- $logger->info( "\tno directories for $label" ) unless @{ $tuple->[1] };
- foreach my $dir ( @{ $tuple->[1] } ) {
- _print_inc_dir_report( $dir );
- }
- }
-
- }
-
-sub _split_paths
- {
- [ map { _expand_filename( $_ ) } split /$Config{path_sep}/, $_[0] || '' ];
- }
-
-
-=pod
-
-Stolen from File::Path::Expand
-
-=cut
-
-sub _expand_filename
- {
- my( $path ) = @_;
- no warnings 'uninitialized';
- $logger->debug( "Expanding path $path\n" );
- $path =~ s{\A~([^/]+)?}{
- _home_of( $1 || $> ) || "~$1"
- }e;
- return $path;
- }
-
-sub _home_of
- {
- require User::pwent;
- my( $user ) = @_;
- my $ent = User::pwent::getpw($user) or return;
- return $ent->dir;
- }
-
-sub _get_default_inc
- {
- require Config;
-
- [ @Config::Config{ _vars() }, '.' ];
- }
-
-sub _vars {
- qw(
- installarchlib
- installprivlib
- installsitearch
- installsitelib
- );
- }
-
-sub _ping_mirrors {
- my $urls = $CPAN::Config->{urllist};
- require URI;
-
- foreach my $url ( @$urls ) {
- my( $obj ) = URI->new( $url );
- next unless _is_pingable_scheme( $obj );
- my $host = $obj->host;
- _print_ping_report( $obj );
- }
-
- }
-
-sub _is_pingable_scheme {
- my( $uri ) = @_;
-
- $uri->scheme eq 'file'
- }
-
-sub _find_good_mirrors {
- require CPAN::Mirrors;
-
- my $mirrors = CPAN::Mirrors->new;
- my $file = do {
- my $file = 'MIRRORED.BY';
- my $local_path = File::Spec->catfile(
- $CPAN::Config->{keep_source_where}, $file );
-
- if( -e $local_path ) { $local_path }
- else {
- require CPAN::FTP;
- CPAN::FTP->localize( $file, $local_path, 3, 1 );
- $local_path;
- }
- };
-
- $mirrors->parse_mirrored_by( $file );
-
- my @mirrors = $mirrors->best_mirrors(
- how_many => 3,
- verbose => 1,
- );
-
- foreach my $mirror ( @mirrors ) {
- next unless eval { $mirror->can( 'http' ) };
- _print_ping_report( $mirror->http );
- }
-
- }
-
-sub _print_inc_dir_report
- {
- my( $dir ) = shift;
-
- my $writeable = -w $dir ? '+' : '!!! (not writeable)';
- $logger->info( "\t$writeable $dir" );
- return -w $dir;
- }
-
-sub _print_ping_report
- {
- my( $mirror ) = @_;
-
- my $rtt = eval { _get_ping_report( $mirror ) };
-
- $logger->info(
- sprintf "\t%s (%4d ms) %s", $rtt ? '+' : '!', $rtt * 1000, $mirror
- );
- }
-
-sub _get_ping_report
- {
- require URI;
- my( $mirror ) = @_;
- my( $url ) = ref $mirror ? $mirror : URI->new( $mirror ); #XXX
- require Net::Ping;
-
- my $ping = Net::Ping->new( 'tcp', 1 );
-
- if( $url->scheme eq 'file' ) {
- return -e $url->file;
- }
-
- my( $port ) = $url->port;
-
- return unless $port;
-
- if ( $ping->can('port_number') ) {
- $ping->port_number($port);
- }
- else {
- $ping->{'port_num'} = $port;
- }
-
- $ping->hires(1) if $ping->can( 'hires' );
- my( $alive, $rtt ) = eval{ $ping->ping( $url->host ) };
- $alive ? $rtt : undef;
- }
-
-sub _load_local_lib # -I
- {
- $logger->debug( "Loading local::lib" );
-
- my $rc = eval { require local::lib; 1; };
- unless( $rc ) {
- $logger->die( "Could not load local::lib" );
- }
-
- local::lib->import;
-
- return HEY_IT_WORKED;
- }
-
+
sub _create_autobundle
{
- $logger->info(
+ $logger->info(
"Creating autobundle in $CPAN::Config->{cpan_home}/Bundle" );
CPAN::Shell->autobundle;
@@ -937,86 +621,85 @@ sub _upgrade
}
sub _load_config # -j
- {
+ {
my $file = shift || '';
-
+
# should I clear out any existing config here?
$CPAN::Config = {};
delete $INC{'CPAN/Config.pm'};
croak( "Config file [$file] does not exist!\n" ) unless -e $file;
-
+
my $rc = eval "require '$file'";
# CPAN::HandleConfig::require_myconfig_or_config looks for this
$INC{'CPAN/MyConfig.pm'} = 'fake out!';
-
+
# CPAN::HandleConfig::load looks for this
$CPAN::Config_loaded = 'fake out';
-
+
croak( "Could not load [$file]: $@\n") unless $rc;
-
+
return HEY_IT_WORKED;
}
-sub _dump_config # -J
+sub _dump_config
{
my $args = shift;
require Data::Dumper;
-
+
my $fh = $args->[0] || \*STDOUT;
-
- local $Data::Dumper::Sortkeys = 1;
- my $dd = Data::Dumper->new(
- [$CPAN::Config],
- ['$CPAN::Config']
+
+ my $dd = Data::Dumper->new(
+ [$CPAN::Config],
+ ['$CPAN::Config']
);
-
+
print $fh $dd->Dump, "\n1;\n__END__\n";
-
+
return HEY_IT_WORKED;
}
-sub _lock_lobotomy # -F
+sub _lock_lobotomy
{
no warnings 'redefine';
-
+
*CPAN::_flock = sub { 1 };
*CPAN::checklock = sub { 1 };
return HEY_IT_WORKED;
}
-
+
sub _download
- {
+ {
my $args = shift;
-
+
local $CPAN::DEBUG = 1;
-
+
my %paths;
-
+
foreach my $module ( @$args )
{
$logger->info( "Checking $module" );
my $path = CPAN::Shell->expand( "Module", $module )->cpan_file;
-
+
$logger->debug( "Inst file would be $path\n" );
-
+
$paths{$module} = _get_file( _make_path( $path ) );
}
-
+
return \%paths;
}
sub _make_path { join "/", qw(authors id), $_[0] }
-
+
sub _get_file
{
my $path = shift;
-
+
my $loaded = eval "require LWP::Simple; 1;";
croak "You need LWP::Simple to use features that fetch files from CPAN\n"
unless $loaded;
-
+
my $file = substr $path, rindex( $path, '/' ) + 1;
my $store_path = catfile( cwd(), $file );
$logger->debug( "Store path is $store_path" );
@@ -1034,13 +717,13 @@ sub _get_file
sub _gitify
{
my $args = shift;
-
+
my $loaded = eval "require Archive::Extract; 1;";
croak "You need Archive::Extract to use features that gitify distributions\n"
unless $loaded;
-
+
my $starting_dir = cwd();
-
+
foreach my $module ( @$args )
{
$logger->info( "Checking $module" );
@@ -1048,23 +731,23 @@ sub _gitify
my $store_paths = _download( [ $module ] );
$logger->debug( "gitify Store path is $store_paths->{$module}" );
- my $dirname = dirname( $store_paths->{$module} );
-
+ my $dirname = dirname( $store_paths->{$module} );
+
my $ae = Archive::Extract->new( archive => $store_paths->{$module} );
$ae->extract( to => $dirname );
-
+
chdir $ae->extract_path;
-
+
my $git = $ENV{GIT_COMMAND} || '/usr/local/bin/git';
croak "Could not find $git" unless -e $git;
croak "$git is not executable" unless -x $git;
-
+
# can we do this in Pure Perl?
system( $git, 'init' );
system( $git, qw( add . ) );
system( $git, qw( commit -a -m ), 'initial import' );
}
-
+
chdir $starting_dir;
return HEY_IT_WORKED;
@@ -1073,42 +756,42 @@ sub _gitify
sub _show_Changes
{
my $args = shift;
-
+
foreach my $arg ( @$args )
{
$logger->info( "Checking $arg\n" );
-
+
my $module = eval { CPAN::Shell->expand( "Module", $arg ) };
my $out = _get_cpanpm_output();
-
+
next unless eval { $module->inst_file };
#next if $module->uptodate;
-
+
( my $id = $module->id() ) =~ s/::/\-/;
-
+
my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
$id . "-" . $module->cpan_version() . "/";
-
+
#print "URL: $url\n";
_get_changes_file($url);
}
return HEY_IT_WORKED;
- }
-
+ }
+
sub _get_changes_file
{
croak "Reading Changes files requires LWP::Simple and URI\n"
unless eval "require LWP::Simple; require URI; 1";
-
+
my $url = shift;
my $content = LWP::Simple::get( $url );
$logger->info( "Got $url ..." ) if defined $content;
#print $content;
-
+
my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
-
+
my $changes_url = URI->new_abs( $change_link, $url );
$logger->debug( "Change link is: $changes_url" );
@@ -1118,11 +801,11 @@ sub _get_changes_file
return HEY_IT_WORKED;
}
-
+
sub _show_Author
- {
+ {
my $args = shift;
-
+
foreach my $arg ( @$args )
{
my $module = CPAN::Shell->expand( "Module", $arg );
@@ -1131,29 +814,29 @@ sub _show_Author
$logger->info( "Didn't find a $arg module, so no author!" );
next;
}
-
+
my $author = CPAN::Shell->expand( "Author", $module->userid );
-
+
next unless $module->userid;
-
- printf "%-25s %-8s %-25s %s\n",
- $arg, $module->userid, $author->email, $author->name;
+
+ printf "%-25s %-8s %-25s %s\n",
+ $arg, $module->userid, $author->email, $author->fullname;
}
return HEY_IT_WORKED;
- }
+ }
sub _show_Details
{
my $args = shift;
-
+
foreach my $arg ( @$args )
{
my $module = CPAN::Shell->expand( "Module", $arg );
my $author = CPAN::Shell->expand( "Author", $module->userid );
-
+
next unless $module->userid;
-
+
print "$arg\n", "-" x 73, "\n\t";
print join "\n\t",
$module->description ? $module->description : "(no description)",
@@ -1165,26 +848,26 @@ sub _show_Details
$author->fullname . " (" . $module->userid . ")",
$author->email;
print "\n\n";
-
+
}
-
+
return HEY_IT_WORKED;
- }
+ }
sub _show_out_of_date
{
my @modules = CPAN::Shell->expand( "Module", "/./" );
-
+
printf "%-40s %6s %6s\n", "Module Name", "Local", "CPAN";
print "-" x 73, "\n";
-
+
foreach my $module ( @modules )
{
next unless $module->inst_file;
next if $module->uptodate;
printf "%-40s %.4f %.4f\n",
- $module->id,
- $module->inst_version ? $module->inst_version : '',
+ $module->id,
+ $module->inst_version ? $module->inst_version : '',
$module->cpan_version;
}
@@ -1196,71 +879,71 @@ sub _show_author_mods
my $args = shift;
my %hash = map { lc $_, 1 } @$args;
-
+
my @modules = CPAN::Shell->expand( "Module", "/./" );
-
+
foreach my $module ( @modules )
{
next unless exists $hash{ lc $module->userid };
print $module->id, "\n";
}
-
+
return HEY_IT_WORKED;
}
-
-sub _list_all_mods # -l
+
+sub _list_all_mods
{
require File::Find;
-
+
my $args = shift;
-
-
+
+
my $fh = \*STDOUT;
-
+
INC: foreach my $inc ( @INC )
- {
+ {
my( $wanted, $reporter ) = _generator();
File::Find::find( { wanted => $wanted }, $inc );
-
+
my $count = 0;
FILE: foreach my $file ( @{ $reporter->() } )
{
my $version = _parse_version_safely( $file );
-
+
my $module_name = _path_to_module( $inc, $file );
next FILE unless defined $module_name;
-
+
print $fh "$module_name\t$version\n";
-
+
#last if $count++ > 5;
}
}
return HEY_IT_WORKED;
}
-
+
sub _generator
- {
+ {
my @files = ();
-
- sub { push @files,
- File::Spec->canonpath( $File::Find::name )
+
+ sub { push @files,
+ File::Spec->canonpath( $File::Find::name )
if m/\A\w+\.pm\z/ },
sub { \@files },
}
-
+
sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
{
my( $file ) = @_;
-
+
local $/ = "\n";
local $_; # don't mess with the $_ in the map calling this
-
+
return unless open FILE, "<$file";
my $in_pod = 0;
my $version;
- while( <FILE> )
+ while( <FILE> )
{
chomp;
$in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
@@ -1268,32 +951,30 @@ sub _parse_version_safely # stolen from PAUSE's mldistwatch, but refactored
next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
my( $sigil, $var ) = ( $1, $2 );
-
+
$version = _eval_version( $_, $sigil, $var );
last;
}
close FILE;
return 'undef' unless defined $version;
-
+
return $version;
}
sub _eval_version
{
my( $line, $sigil, $var ) = @_;
-
- # split package line to hide from PAUSE
- my $eval = qq{
- package
- ExtUtils::MakeMaker::_version;
+
+ my $eval = qq{
+ package ExtUtils::MakeMaker::_version;
local $sigil$var;
\$$var=undef; do {
$line
}; \$$var
};
-
+
my $version = do {
local $^W = 0;
no strict;
@@ -1307,16 +988,16 @@ sub _path_to_module
{
my( $inc, $path ) = @_;
return if length $path< length $inc;
-
+
my $module_path = substr( $path, length $inc );
$module_path =~ s/\.pm\z//;
-
+
# XXX: this is cheating and doesn't handle everything right
my @dirs = grep { ! /\W/ } File::Spec->splitdir( $module_path );
shift @dirs;
-
+
my $module_name = join "::", @dirs;
-
+
return $module_name;
}
@@ -1326,7 +1007,7 @@ sub _path_to_module
=head1 EXIT VALUES
-The script exits with zero if it thinks that everything worked, or a
+The script exits with zero if it thinks that everything worked, or a
positive number if it thinks that something failed. Note, however, that
in some cases it has to divine a failure by the output of things it does
not control. For now, the exit codes are vague:
@@ -1348,16 +1029,6 @@ correctly if Log4perl is not installed.
* When I capture CPAN.pm output, I need to check for errors and
report them to the user.
-* Support local::lib
-
-* Warnings switch
-
-* Check then exit
-
-* ping mirrors support
-
-* no test option
-
=head1 BUGS
* none noted
@@ -1375,23 +1046,21 @@ This code is in Github:
=head1 CREDITS
-Japheth Cleaver added the bits to allow a forced install (C<-f>).
+Japheth Cleaver added the bits to allow a forced install (-f).
Jim Brandt suggest and provided the initial implementation for the
up-to-date and Changes features.
-Adam Kennedy pointed out that C<exit()> causes problems on Windows
+Adam Kennedy pointed out that exit() causes problems on Windows
where this script ends up with a .bat extension
-David Golden helps integrate this into the C<CPAN.pm> repos.
-
=head1 AUTHOR
brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT
-Copyright (c) 2001-2013, brian d foy, All Rights Reserved.
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm
index 4ed4b6cdd00..9d09708afcc 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm
@@ -2,7 +2,7 @@
# vim: ts=4 sts=4 sw=4:
use strict;
package CPAN;
-$CPAN::VERSION = '2.05';
+$CPAN::VERSION = '1.94_56';
$CPAN::VERSION =~ s/_//;
# we need to run chdir all over and we would get at wrong libraries
@@ -37,7 +37,6 @@ use CPAN::Shell;
use CPAN::LWP::UserAgent;
use CPAN::Exception::RecursiveDependency;
use CPAN::Exception::yaml_not_installed;
-use CPAN::Exception::yaml_process_error;
use Carp ();
use Config ();
@@ -548,7 +547,7 @@ sub _yaml_loadfile {
return +[] unless -s $local_file;
my $yaml_module = _yaml_module;
if ($CPAN::META->has_inst($yaml_module)) {
- # temporarily enable yaml code deserialisation
+ # temporarly enable yaml code deserialisation
no strict 'refs';
# 5.6.2 could not do the local() with the reference
# so we do it manually instead
@@ -824,14 +823,15 @@ Please make sure the directory exists and is writable.
if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
my $fh;
unless ($fh = FileHandle->new("+>>$lockfile")) {
- $CPAN::Frontend->mywarn(qq{
+ if ($! =~ /Permission/) {
+ $CPAN::Frontend->mywarn(qq{
Your configuration suggests that CPAN.pm should use a working
directory of
$CPAN::Config->{cpan_home}
Unfortunately we could not create the lock file
$lockfile
-due to '$!'.
+due to permission problems.
Please make sure that the configuration variable
\$CPAN::Config->{cpan_home}
@@ -839,7 +839,8 @@ points to a directory where you can write a .lock file. You can set
this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
\@INC path;
});
- return suggest_myconfig;
+ return suggest_myconfig;
+ }
}
my $sleep = 1;
while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
@@ -886,7 +887,7 @@ this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
# be politely squashed. Any bug that causes every eval {} to have to be
# modified should be not so politely squashed.
#
-# Those are my current opinions. It is also my opinion that polite
+# Those are my current opinions. It is also my optinion that polite
# arguments degenerate to personal arguments far too frequently, and that
# when they do, it's because both people wanted it to, or at least didn't
# sufficiently want it not to.
@@ -922,53 +923,31 @@ sub fastcwd {Cwd::fastcwd();}
#-> sub CPAN::backtickcwd ;
sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
-# Adapted from Probe::Perl
-#-> sub CPAN::_perl_is_same
-sub _perl_is_same {
- my ($perl) = @_;
- return MM->maybe_command($perl)
- && `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
-}
-
-# Adapted in part from Probe::Perl
#-> sub CPAN::find_perl ;
sub find_perl () {
- if ( File::Spec->file_name_is_absolute($^X) ) {
- return $^X;
+ my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
+ unless ($perl) {
+ my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
+ $^X = $perl = $candidate if MM->maybe_command($candidate);
}
- else {
- my $exe = $Config::Config{exe_ext};
- my @candidates = (
- File::Spec->catfile($CPAN::iCwd,$^X),
- $Config::Config{'perlpath'},
- );
- for my $perl_name ($^X, 'perl', 'perl5', "perl$]") {
- for my $path (File::Spec->path(), $Config::Config{'binexp'}) {
- if ( defined($path) && length $path && -d $path ) {
- my $perl = File::Spec->catfile($path,$perl_name);
- push @candidates, $perl;
- # try with extension if not provided already
- if ($^O eq 'VMS') {
- # VMS might have a file version at the end
- push @candidates, $perl . $exe
- unless $perl =~ m/$exe(;\d+)?$/i;
- } elsif (defined $exe && length $exe) {
- push @candidates, $perl . $exe
- unless $perl =~ m/$exe$/i;
- }
+ unless ($perl) {
+ my ($component,$perl_name);
+ DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
+ PATH_COMPONENT: foreach $component (File::Spec->path(),
+ $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = File::Spec->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $^X = $perl = $abs;
+ last DIST_PERLNAME;
}
}
}
- for my $perl ( @candidates ) {
- if (MM->maybe_command($perl) && _perl_is_same($perl)) {
- $^X = $perl;
- return $perl;
- }
- }
}
- return $^X; # default fall back
+ return $perl;
}
+
#-> sub CPAN::exists ;
sub exists {
my($mgr,$class,$id) = @_;
@@ -1008,17 +987,6 @@ sub has_usable {
#
# these subroutines die if they believe the installed version is unusable;
#
- 'CPAN::Meta' => [
- sub {
- require CPAN::Meta;
- unless (CPAN::Version->vge(CPAN::Meta->VERSION, 2.110350)) {
- for ("Will not use CPAN::Meta, need version 2.110350\n") {
- $CPAN::Frontend->mywarn($_);
- die $_;
- }
- }
- },
- ],
LWP => [ # we frequently had "Can't locate object
# method "new" via package "LWP::UserAgent" at
@@ -1039,17 +1007,6 @@ sub has_usable {
sub {require Net::FTP},
sub {require Net::Config},
],
- 'HTTP::Tiny' => [
- sub {
- require HTTP::Tiny;
- unless (CPAN::Version->vge(HTTP::Tiny->VERSION, 0.005)) {
- for ("Will not use HTTP::Tiny, need version 0.005\n") {
- $CPAN::Frontend->mywarn($_);
- die $_;
- }
- }
- },
- ],
'File::HomeDir' => [
sub {require File::HomeDir;
unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
@@ -1070,7 +1027,7 @@ sub has_usable {
# don't die, because we may need
# Archive::Tar to upgrade
}
-
+
}
},
],
@@ -1111,7 +1068,7 @@ sub has_inst {
my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
keys %{$CPAN::Config->{dontload_hash}||{}},
@{$CPAN::Config->{dontload_list}||[]};
- if (defined $message && $message eq "no" # as far as I remember only used by Nox
+ if (defined $message && $message eq "no" # afair only used by Nox
||
$dont{$mod}
) {
@@ -1125,7 +1082,7 @@ sub has_inst {
if ($INC{$file}) {
# checking %INC is wrong, because $INC{LWP} may be true
# although $INC{"URI/URL.pm"} may have failed. But as
- # I really want to say "blah loaded OK", I have to somehow
+ # I really want to say "bla loaded OK", I have to somehow
# cache results.
### warn "$file in %INC"; #debug
return 1;
@@ -1185,7 +1142,7 @@ sub has_inst {
CPAN: Module::Signature security checks disabled because Module::Signature
not installed. Please consider installing the Module::Signature module.
You may also need to be able to connect over the Internet to the public
- key servers like pool.sks-keyservers.net or pgp.mit.edu.
+ keyservers like pgp.mit.edu (port 11371).
});
$CPAN::Frontend->mysleep(2);
@@ -1212,12 +1169,6 @@ sub new {
bless {}, shift;
}
-#-> sub CPAN::_exit_messages ;
-sub _exit_messages {
- my ($self) = @_;
- $self->{exit_messages} ||= [];
-}
-
#-> sub CPAN::cleanup ;
sub cleanup {
# warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
@@ -1234,7 +1185,6 @@ sub cleanup {
return unless defined $META->{LOCK};
return unless -f $META->{LOCK};
$META->savehist;
- $META->{cachemgr} ||= CPAN::CacheMgr->new('atexit');
close $META->{LOCKFH};
unlink $META->{LOCK};
# require Carp;
@@ -1243,9 +1193,6 @@ sub cleanup {
$CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
}
$CPAN::Frontend->myprint("Lockfile removed.\n");
- for my $msg ( @{ $META->_exit_messages } ) {
- $CPAN::Frontend->myprint($msg);
- }
}
#-> sub CPAN::readhist
@@ -1316,28 +1263,9 @@ sub is_installed {
sub _list_sorted_descending_is_tested {
my($self) = @_;
- my $foul = 0;
- my @sorted = sort
+ sort
{ ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
- grep
- { if ($foul){ 0 } elsif (-e) { 1 } else { $foul = $_; 0 } }
- keys %{$self->{is_tested}};
- if ($foul) {
- $CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n");
- for my $dbd (keys %{$self->{is_tested}}) { # distro-build-dir
- SEARCH: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
- if ($d->{build_dir} && $d->{build_dir} eq $dbd) {
- $CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id);
- $d->fforce("");
- last SEARCH;
- }
- }
- delete $self->{is_tested}{$dbd};
- }
- return ();
- } else {
- return @sorted;
- }
+ keys %{$self->{is_tested}}
}
#-> sub CPAN::set_perl5lib
@@ -1437,8 +1365,8 @@ Basic commands:
The CPAN module automates or at least simplifies the make and install
of perl modules and extensions. It includes some primitive searching
-capabilities and knows how to use LWP, HTTP::Tiny, Net::FTP and certain
-external download clients to fetch distributions from the net.
+capabilities and knows how to use Net::FTP, LWP, and certain external
+download clients to fetch distributions from the net.
These are fetched from one or more mirrored CPAN (Comprehensive
Perl Archive Network) sites and unpacked in a dedicated directory.
@@ -1489,14 +1417,14 @@ mentioned four. Each of the four entities is implemented as a class
with slightly differing methods for displaying an object.
Arguments to these commands are either strings exactly matching
-the identification string of an object, or regular expressions
+the identification string of an object, or regular expressions
matched case-insensitively against various attributes of the
objects. The parser only recognizes a regular expression when you
enclose it with slashes.
The principle is that the number of objects found influences how an
item is displayed. If the search finds one item, the result is
-displayed with the rather verbose method C<as_string>, but if
+displayed with the rather verbose method C<as_string>, but if
more than one is found, each object is displayed with the terse method
C<as_glimpse>.
@@ -1608,7 +1536,7 @@ being executed within the distribution file's working directory.
C<readme> displays the README file of the associated distribution.
C<Look> gets and untars (if not yet done) the distribution file,
changes to the appropriate directory and opens a subshell process in
-that directory. C<perldoc> displays the module's pod documentation
+that directory. C<perldoc> displays the module's pod documentation
in html or plain text format.
=item C<ls> author
@@ -1719,13 +1647,8 @@ literal backslash.
C<autobundle> writes a bundle file into the
C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
a list of all modules that are both available from CPAN and currently
-installed within @INC. Duplicates of each distribution are suppressed.
-The name of the bundle file is based on the current date and a
-counter, e.g. F<Bundle/Snapshot_2012_05_21_00.pm>. This is installed
-again by running C<cpan Bundle::Snapshot_2012_05_21_00>, or installing
-C<Bundle::Snapshot_2012_05_21_00> from the CPAN shell.
-
-Return value: path to the written file.
+installed within @INC. The name of the bundle file is based on the
+current date and a counter.
=head2 hosts
@@ -1737,56 +1660,16 @@ activities. The data for this is collected in the YAML file
C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
configured or YAML not installed, no stats are provided.
-=over
-
-=item install_tested
-
-Install all distributions that have been tested successfully but have
-not yet been installed. See also C<is_tested>.
-
-=item is_tested
-
-List all build directories of distributions that have been tested
-successfully but have not yet been installed. See also
-C<install_tested>.
-
-=back
-
=head2 mkmyconfig
mkmyconfig() writes your own CPAN::MyConfig file into your C<~/.cpan/>
directory so that you can save your own preferences instead of the
system-wide ones.
-=head2 r [Module|/Regexp/]...
-
-scans current perl installation for modules that have a newer version
-available on CPAN and provides a list of them. If called without
-argument, all potential upgrades are listed; if called with arguments
-the list is filtered to the modules and regexps given as arguments.
-
-The listing looks something like this:
-
- Package namespace installed latest in CPAN file
- CPAN 1.94_64 1.9600 ANDK/CPAN-1.9600.tar.gz
- CPAN::Reporter 1.1801 1.1902 DAGOLDEN/CPAN-Reporter-1.1902.tar.gz
- YAML 0.70 0.73 INGY/YAML-0.73.tar.gz
- YAML::Syck 1.14 1.17 AVAR/YAML-Syck-1.17.tar.gz
- YAML::Tiny 1.44 1.50 ADAMK/YAML-Tiny-1.50.tar.gz
- CGI 3.43 3.55 MARKSTOS/CGI.pm-3.55.tar.gz
- Module::Build::YAML 1.40 1.41 DAGOLDEN/Module-Build-0.3800.tar.gz
- TAP::Parser::Result::YAML 3.22 3.23 ANDYA/Test-Harness-3.23.tar.gz
- YAML::XS 0.34 0.35 INGY/YAML-LibYAML-0.35.tar.gz
-
-It suppresses duplicates in the column C<in CPAN file> such that
-distributions with many upgradeable modules are listed only once.
-
-Note that the list is not sorted.
-
=head2 recent ***EXPERIMENTAL COMMAND***
The C<recent> command downloads a list of recent uploads to CPAN and
-displays them I<slowly>. While the command is running, a $SIG{INT}
+displays them I<slowly>. While the command is running, a $SIG{INT}
exits the loop after displaying the current item.
B<Note>: This command requires XML::LibXML installed.
@@ -1801,7 +1684,7 @@ B<Note>: See also L<smoke>
recompile() is a special command that takes no argument and
runs the make/test/install cycle with brute force over all installed
-dynamically loadable extensions (a.k.a. XS modules) with 'force' in
+dynamically loadable extensions (aka XS modules) with 'force' in
effect. The primary purpose of this command is to finish a network
installation. Imagine you have a common source tree for two different
architectures. You decide to do a completely independent fresh
@@ -1841,7 +1724,7 @@ approach will likely remain.
B<Note>: See also L<recent>
-=head2 upgrade [Module|/Regexp/]...
+=head2 upgrade [Module|/Regex/]...
The C<upgrade> command first runs an C<r> command with the given
arguments and then installs the newest versions of all modules that
@@ -1865,7 +1748,7 @@ separated):
Modules know their associated Distribution objects. They always refer
to the most recent official release. Developers may mark their releases
-as unstable development versions (by inserting an unserscore into the
+as unstable development versions (by inserting an underbar into the
module version number which will also be reflected in the distribution
name when you run 'make dist'), so the really hottest and newest
distribution is not always the default. If a module Foo circulates
@@ -1960,7 +1843,7 @@ Example:
o conf shell
If KEY starts and ends with a slash, the string in between is
-treated as a regular expression and only keys matching this regexp
+treated as a regular expression and only keys matching this regex
are displayed
Example:
@@ -2047,8 +1930,7 @@ currently defined:
dontload_list arrayref: modules in the list will not be
loaded by the CPAN::has_inst() routine
ftp path to external prg
- ftp_passive if set, the environment variable FTP_PASSIVE is set
- for downloads
+ ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
ftp_proxy proxy host for ftp requests
ftpstats_period max number of days to keep download statistics
ftpstats_size max number of items to keep in the download statistics
@@ -2063,7 +1945,7 @@ currently defined:
inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
after this many seconds inactivity. Set to 0 to
disable timeouts.
- index_expire refetch index files after this many days
+ index_expire refetch index files after this many days
inhibit_startup_message
if true, suppress the startup message
keep_source_where directory in which to keep the source (if we do)
@@ -2091,10 +1973,6 @@ currently defined:
patch path to external prg
patches_dir local directory containing patch files
perl5lib_verbosity verbosity level for PERL5LIB additions
- prefer_external_tar
- per default all untar operations are done with
- Archive::Tar; by setting this variable to true
- the external tar command is used if available
prefer_installer legal values are MB and EUMM: if a module comes
with both a Makefile.PL and a Build.PL, use the
former (EUMM) or the latter (MB); if the module
@@ -2110,14 +1988,12 @@ currently defined:
proxy_user username for accessing an authenticating proxy
proxy_pass password for accessing an authenticating proxy
randomize_urllist add some randomness to the sequence of the urllist
- recommends_policy whether recommended prerequisites should be included
- scan_cache controls scanning of cache ('atstart', 'atexit' or 'never')
+ scan_cache controls scanning of cache ('atstart' or 'never')
shell your favorite shell
show_unparsable_versions
boolean if r command tells which modules are versionless
show_upload_date boolean if commands should try to determine upload date
show_zero_versions boolean if r command tells for which modules $version==0
- suggests_policy whether suggested prerequisites should be included
tar location of external program tar
tar_verbosity verbosity level for the tar command
term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
@@ -2129,7 +2005,6 @@ currently defined:
CPAN::Reporter history)
unzip location of external program unzip
urllist arrayref to nearby CPAN sites (or equivalent locations)
- use_prompt_default set PERL_MM_USE_DEFAULT for configure/make/test/install
use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
username your username if you CPAN server wants one
version_timeout stops version parsing after this many seconds.
@@ -2260,7 +2135,7 @@ randomness into the URL selection.
Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
a distribution are treated differently depending on the config
variable C<build_requires_install_policy>. By setting
-C<build_requires_install_policy> to C<no>, such a module is not
+C<build_requires_install_policy> to C<no>, such a module is not
installed. It is only built and tested, and then kept in the list of
tested but uninstalled modules. As such, it is available during the
build of the dependent module by integrating the path to the
@@ -2314,7 +2189,7 @@ temporarily override assorted C<CPAN.pm> configuration variables
=item
-specify dependencies the original maintainer forgot
+specify dependencies the original maintainer forgot
=item
@@ -2502,7 +2377,7 @@ CPAN mantra. See below under I<Processing Instructions>.
=item match [hash]
-A hashref with one or more of the keys C<distribution>, C<module>,
+A hashref with one or more of the keys C<distribution>, C<modules>,
C<perl>, C<perlconfig>, and C<env> that specify whether a document is
targeted at a specific CPAN distribution or installation.
Keys prefixed with C<not_> negates the corresponding match.
@@ -2540,7 +2415,7 @@ parameter is C<0> or C<1> is determined by reading the patch
beforehand. The path to each patch is either an absolute path on the
local filesystem or relative to a patch directory specified in the
C<patches_dir> configuration variable or in the format of a canonical
-distro name. For examples please consult the distroprefs/ directory in
+distroname. For examples please consult the distroprefs/ directory in
the CPAN.pm distribution (these examples are not installed by
default).
@@ -2651,7 +2526,7 @@ needs. You have been warned:-)
=head1 PROGRAMMER'S INTERFACE
-If you do not enter the shell, shell commands are
+If you do not enter the shell, shell commands are
available both as methods (C<CPAN::Shell-E<gt>install(...)>) and as
functions in the calling package (C<install(...)>). Before calling low-level
commands, it makes sense to initialize components of CPAN you need, e.g.:
@@ -2664,20 +2539,9 @@ High-level commands do such initializations automatically.
There's currently only one class that has a stable interface -
CPAN::Shell. All commands that are available in the CPAN shell are
-methods of the class CPAN::Shell. The arguments on the commandline are
-passed as arguments to the method.
-
-So if you take for example the shell command
-
- notest install A B C
-
-the actually executed command is
-
- CPAN::Shell->notest("install","A","B","C");
-
-Each of the commands that produce listings of modules (C<r>,
-C<autobundle>, C<u>) also return a list of the IDs of all modules
-within the list.
+methods of the class CPAN::Shell. Each of the commands that produce
+listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
+the IDs of all modules within the list.
=over 2
@@ -2729,7 +2593,7 @@ all modules that need updating. First a quick and dirty way:
If you don't want any output should all modules be
up to date, parse the output of above command for the regular
expression C</modules are up to date/> and decide to mail the output
-only if it doesn't match.
+only if it doesn't match.
If you prefer to do it more in a programmerish style in one single
process, something like this may better suit you:
@@ -2825,7 +2689,7 @@ Like CPAN::Bundle::inst_file, but returns the $VERSION
=item CPAN::Bundle::uptodate()
-Returns 1 if the bundle itself and all its members are up-to-date.
+Returns 1 if the bundle itself and all its members are uptodate.
=item CPAN::Bundle::install()
@@ -2916,11 +2780,16 @@ cancellation can be avoided by letting C<force> run the C<install> for
you.
This install method only has the power to install the distribution if
-there are no dependencies in the way. To install an object along with all
+there are no dependencies in the way. To install an object along with all
its dependencies, use CPAN::Shell->install.
Note that install() gives no meaningful return value. See uptodate().
+=item CPAN::Distribution::install_tested()
+
+Install all distributions that have tested sucessfully but
+not yet installed. See also C<is_tested>.
+
=item CPAN::Distribution::isa_perl()
Returns 1 if this distribution file seems to be a perl distribution.
@@ -2954,7 +2823,7 @@ in C<< $CPAN::Config->{pager} >>.
Returns the hash reference from the first matching YAML file that the
user has deposited in the C<prefs_dir/> directory. The first
succeeding match wins. The files in the C<prefs_dir/> are processed
-alphabetically, and the canonical distro name (e.g.
+alphabetically, and the canonical distroname (e.g.
AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
stored in the $root->{match}{distribution} attribute value.
Additionally all module names contained in a distribution are matched
@@ -2999,7 +2868,7 @@ runs C<make test> there.
=item CPAN::Distribution::uptodate()
Returns 1 if all the modules contained in the distribution are
-up-to-date. Relies on containsmods.
+uptodate. Relies on containsmods.
=item CPAN::Index::force_reload()
@@ -3022,7 +2891,7 @@ internal and thus subject to change without notice.
Returns a one-line description of the module in four columns: The
first column contains the word C<Module>, the second column consists
of one character: an equals sign if this module is already installed
-and up-to-date, a less-than sign if this module is installed but can be
+and uptodate, a less-than sign if this module is installed but can be
upgraded, and a space if the module is not installed. The third column
is the name of the module and the fourth column gives maintainer or
distribution information.
@@ -3084,7 +2953,7 @@ Where the 'DSLIP' characters have the following meanings:
d - Developer
u - Usenet newsgroup comp.lang.perl.modules
n - None known, try comp.lang.perl.modules
- a - abandoned; volunteers welcome to take over maintenance
+ a - abandoned; volunteers welcome to take over maintainance
L - Language Used:
p - Perl-only, no compiler needed, should be platform independent
@@ -3108,9 +2977,9 @@ Where the 'DSLIP' characters have the following meanings:
b - BSD: The BSD License
a - Artistic license alone
2 - Artistic license 2.0 or later
- o - open source: approved by www.opensource.org
+ o - open source: appoved by www.opensource.org
d - allows distribution without restrictions
- r - restricted distribution
+ r - restricted distribtion
n - no license at all
=item CPAN::Module::force($method,@args)
@@ -3229,7 +3098,7 @@ In this pod section each line obeys the format
Module_Name [Version_String] [- optional text]
The only required part is the first field, the name of a module
-(e.g. Foo::Bar, i.e. I<not> the name of the distribution file). The rest
+(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
of the line is optional. The comment part is delimited by a dash just
as in the man page header.
@@ -3247,7 +3116,7 @@ modules in a snapshot bundle file.
=head1 PREREQUISITES
The CPAN program is trying to depend on as little as possible so the
-user can use it in hostile environment. It works better the more goodies
+user can use it in hostile enviroment. It works better the more goodies
the environment provides. For example if you try in the CPAN shell
install Bundle::CPAN
@@ -3305,7 +3174,7 @@ the software producing the indices on CPAN, the mirroring process on CPAN,
packaging, configuration, synchronicity, and even (gasp!) due to bugs
within the CPAN.pm module itself.
-For debugging the code of CPAN.pm itself in interactive mode, some
+For debugging the code of CPAN.pm itself in interactive mode, some
debugging aid can be turned on for most packages within
CPAN.pm with one of
@@ -3407,7 +3276,7 @@ requires that you have at least one of Crypt::OpenPGP module or the
command-line F<gpg> tool installed.
You will also need to be able to connect over the Internet to the public
-key servers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
+keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
The configuration parameter check_sigs is there to turn signature
checking on or off.
@@ -3461,12 +3330,12 @@ Maintaining a bundle definition file means keeping track of two
things: dependencies and interactivity. CPAN.pm sometimes fails on
calculating dependencies because not all modules define all MakeMaker
attributes correctly, so a bundle definition file should specify
-prerequisites as early as possible. On the other hand, it's
+prerequisites as early as possible. On the other hand, it's
annoying that so many distributions need some interactive configuring. So
what you can try to accomplish in your private bundle file is to have the
packages that need to be configured early in the file and the gentle
-ones later, so you can go out for coffee after a few minutes and leave CPAN.pm
-to churn away unattended.
+ones later, so you can go out for cofeee after a few minutes and leave CPAN.pm
+to churn away untended.
=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
@@ -3492,7 +3361,7 @@ or in your web browser you've proxy information set, then you know
you are running behind an http firewall.
To access servers outside these types of firewalls with perl (even for
-ftp), you need LWP or HTTP::Tiny.
+ftp), you need LWP.
=item ftp firewall
@@ -3506,7 +3375,7 @@ need Net::FTP.
=item One-way visibility
-One-way visibility means these firewalls try to make themselves
+One-way visibility means these firewalls try to make themselves
invisible to users inside the firewall. An FTP data connection is
normally created by sending your IP address to the remote server and then
listening for the return connection. But the remote server will not be able to
@@ -3618,10 +3487,54 @@ so that STDOUT is captured in a file for later inspection.
I am not root, how can I install a module in a personal directory?
-As of CPAN 1.9463, if you do not have permission to write the default perl
-library directories, CPAN's configuration process will ask you whether
-you want to bootstrap <local::lib>, which makes keeping a personal
-perl library directory easy.
+First of all, you will want to use your own configuration, not the one
+that your root user installed. If you do not have permission to write
+in the cpan directory that root has configured, you will be asked if
+you want to create your own config. Answering "yes" will bring you into
+CPAN's configuration stage, using the system config for all defaults except
+things that have to do with CPAN's work directory, saving your choices to
+your MyConfig.pm file.
+
+You can also manually initiate this process with the following command:
+
+ % perl -MCPAN -e 'mkmyconfig'
+
+or by running
+
+ mkmyconfig
+
+from the CPAN shell.
+
+You will most probably also want to configure something like this:
+
+ o conf makepl_arg "LIB=~/myperl/lib \
+ INSTALLMAN1DIR=~/myperl/man/man1 \
+ INSTALLMAN3DIR=~/myperl/man/man3 \
+ INSTALLSCRIPT=~/myperl/bin \
+ INSTALLBIN=~/myperl/bin"
+
+and then the equivalent command for Module::Build, which is
+
+ o conf mbuildpl_arg "--lib=~/myperl/lib \
+ --installman1dir=~/myperl/man/man1 \
+ --installman3dir=~/myperl/man/man3 \
+ --installscript=~/myperl/bin \
+ --installbin=~/myperl/bin"
+
+You can make this setting permanent like all C<o conf> settings with
+C<o conf commit> or by setting C<auto_commit> beforehand.
+
+You will have to add ~/myperl/man to the MANPATH environment variable
+and also tell your perl programs to look into ~/myperl/lib, e.g. by
+including
+
+ use lib "$ENV{HOME}/myperl/lib";
+
+or setting the PERL5LIB environment variable.
+
+While we're speaking about $ENV{HOME}, it might be worth mentioning,
+that for Windows we use the File::HomeDir module that provides an
+equivalent to the concept of the home directory on Unix.
Another thing you should bear in mind is that the UNINST parameter can
be dangerous when you are installing into a private area because you
@@ -3684,7 +3597,7 @@ would be
cpan> o conf term_is_latin 1
-If other charset support is needed, please file a bug report against
+If other charset support is needed, please file a bugreport against
CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
the support or maybe UTF-8 terminals become widely available.
@@ -3746,19 +3659,15 @@ http://search.cpan.org/dist/Module-Build-Convert/
I'm frequently irritated with the CPAN shell's inability to help me
select a good mirror.
-CPAN can now help you select a "good" mirror, based on which ones have the
-lowest 'ping' round-trip times. From the shell, use the command 'o conf init
-urllist' and allow CPAN to automatically select mirrors for you.
-
-Beyond that help, the urllist config parameter is yours. You can add and remove
-sites at will. You should find out which sites have the best up-to-dateness,
-bandwidth, reliability, etc. and are topologically close to you. Some people
-prefer fast downloads, others up-to-dateness, others reliability. You decide
-which to try in which order.
+The urllist config parameter is yours. You can add and remove sites at
+will. You should find out which sites have the best uptodateness,
+bandwidth, reliability, etc. and are topologically close to you. Some
+people prefer fast downloads, others uptodateness, others reliability.
+You decide which to try in which order.
Henk P. Penning maintains a site that collects data about CPAN sites:
- http://mirrors.cpan.org/
+ http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
Also, feel free to play with experimental features. Run
@@ -3793,11 +3702,9 @@ Speaking of the build directory. Do I have to clean it up myself?
You have the choice to set the config variable C<scan_cache> to
C<never>. Then you must clean it up yourself. The other possible
-values, C<atstart> and C<atexit> clean up the build directory when you
-start (or more precisely, after the first extraction into the build
-directory) or exit the CPAN shell, respectively. If you never start up
-the CPAN shell, you probably also have to clean up the build directory
-yourself.
+value, C<atstart> only cleans up the build directory when you start
+the CPAN shell. If you never start up the CPAN shell, you probably
+also have to clean up the build directory yourself.
=back
@@ -3805,7 +3712,7 @@ yourself.
=head2 OLD PERL VERSIONS
-CPAN.pm is regularly tested to run under 5.005 and assorted
+CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
newer versions. It is getting more and more difficult to get the
minimal prerequisites working on older perls. It is close to
impossible to get the whole Bundle::CPAN working there. If you're in
@@ -3822,11 +3729,6 @@ This module and its competitor, the CPANPLUS module, are both much
cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
more modular, but it was never intended to be compatible with CPAN.pm.
-=head2 CPANMINUS
-
-In the year 2010 App::cpanminus was launched as a new approach to a
-cpan shell with a considerably smaller footprint. Very cool stuff.
-
=head1 SECURITY ADVICE
This software enables you to upgrade software on your computer and so
@@ -3869,8 +3771,4 @@ your operating system) then typing C<cpan> in a console window will
work for you as well. Above that the utility provides several
commandline shortcuts.
-melezhik (Alexey) sent me a link where he published a chef recipe to
-work with CPAN.pm: http://community.opscode.com/cookbooks/cpan.
-
-
=cut
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Author.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Author.pm
index 572f3ab31d5..e9e9226be5d 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Author.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Author.pm
@@ -8,7 +8,7 @@ use CPAN::InfoObj;
use vars qw(
$VERSION
);
-$VERSION = "5.5002";
+$VERSION = "5.5";
package CPAN::Author;
use strict;
@@ -178,7 +178,7 @@ sub dir_listing {
$lc_file = $lc_want;
# we *could* second-guess and if the user has a file: URL,
# then we could look there. But on the other hand, if they do
- # have a file: URL, why did they choose to set
+ # have a file: URL, wy did they choose to set
# $CPAN::Config->{show_upload_date} to false?
}
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm
index 1525dde5e32..e7360f80485 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm
@@ -8,7 +8,7 @@ use CPAN::Module;
use vars qw(
$VERSION
);
-$VERSION = "5.5001";
+$VERSION = "5.5";
sub look {
my $self = shift;
@@ -228,10 +228,7 @@ Going to $meth that.
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->{reqtype} = $self->{reqtype};
- # $obj->$meth();
- # XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
- # A: Sure, what could demand otherwise? --andk, 2013-11-25
- CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
+ $obj->$meth();
}
}
@@ -269,7 +266,7 @@ sub clean { shift->rematein('clean',@_); }
#-> sub CPAN::Bundle::uptodate ;
sub uptodate {
my($self) = @_;
- return 0 unless $self->SUPER::uptodate; # we must have the current Bundle def
+ return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
my $c;
foreach $c ($self->contains) {
my $obj = CPAN::Shell->expandany($c);
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/CacheMgr.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/CacheMgr.pm
index 144efd62b3b..827baeaefdb 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/CacheMgr.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/CacheMgr.pm
@@ -10,7 +10,7 @@ use File::Find;
use vars qw(
$VERSION
);
-$VERSION = "5.5002";
+$VERSION = "5.5";
package CPAN::CacheMgr;
use strict;
@@ -49,7 +49,6 @@ sub tidyup {
$self->_clean_cache($toremove);
return if $CPAN::Signal;
}
- $self->{FIFO} = [];
}
#-> sub CPAN::CacheMgr::dir ;
@@ -172,7 +171,7 @@ sub _clean_cache {
} elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
$CPAN::META->delete("CPAN::Distribution", $id);
- # XXX we should restore the state NOW, otherwise this
+ # XXX we should restore the state NOW, otherise this
# distro does not exist until we read an index. BUG ALERT(?)
# $CPAN::Frontend->mywarn (" +++\n");
@@ -190,8 +189,7 @@ sub _clean_cache {
#-> sub CPAN::CacheMgr::new ;
sub new {
- my($class,$phase) = @_;
- $phase ||= "atstart";
+ my $class = shift;
my $time = time;
my($debug,$t2);
$debug = "";
@@ -201,12 +199,10 @@ sub new {
SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
DU => 0
};
- $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
- unless $self->{SCAN} =~ /never|atstart|atexit/;
File::Path::mkpath($self->{ID});
my $dh = DirHandle->new($self->{ID});
bless $self, $class;
- $self->scan_cache($phase);
+ $self->scan_cache;
$t2 = time;
$debug .= "timing of CacheMgr->new: ".($t2 - $time);
$time = $t2;
@@ -216,9 +212,10 @@ sub new {
#-> sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
- my ($self, $phase) = @_;
- $phase = '' unless defined $phase;
- return unless $phase eq $self->{SCAN};
+ my $self = shift;
+ return if $self->{SCAN} eq 'never';
+ $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
+ unless $self->{SCAN} eq 'atstart';
return unless $CPAN::META->{LOCK};
$CPAN::Frontend->myprint(
sprintf("Scanning cache %s for sizes\n",
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Complete.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Complete.pm
index 588e6e6c2cf..e1fe896d4a5 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Complete.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Complete.pm
@@ -4,7 +4,7 @@ package CPAN::Complete;
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
# Q: where is the "How do I add a new command" HOWTO?
-# A: git log -p -1 355c44e9caaec857e4b12f51afb96498833c3e36 where andk added the report command
+# A: svn diff -r 1048:1049 where andk added the report command
@CPAN::Complete::COMMANDS = sort qw(
? ! a b d h i m o q r u
autobundle
@@ -42,7 +42,7 @@ use strict;
use vars qw(
$VERSION
);
-$VERSION = "5.5001";
+$VERSION = "5.5";
package CPAN::Complete;
use strict;
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Debug.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Debug.pm
index 48e394bd419..23c4a3685b6 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Debug.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Debug.pm
@@ -71,10 +71,6 @@ sub debug {
__END__
-=head1 NAME
-
-CPAN::Debug - internal debugging for CPAN.pm
-
=head1 LICENSE
This program is free software; you can redistribute it and/or
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm
index 9a0870717da..ac8f873a130 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm
@@ -1,15 +1,11 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
package CPAN::Distribution;
use strict;
use Cwd qw(chdir);
use CPAN::Distroprefs;
-use CPAN::Meta::Requirements 2;
use CPAN::InfoObj;
-use File::Path ();
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
-$VERSION = "2.02";
+$VERSION = "1.9456_01";
# Accessors
sub cpan_comment {
@@ -71,7 +67,7 @@ sub normalize {
} elsif (
$s =~ tr|/|| == 1
or
- $s !~ m|[A-Z]/[A-Z-0-9]{2}/[A-Z-0-9]{2,}/|
+ $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
) {
return $s if $s =~ m:^N/A|^Contact Author: ;
$s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
@@ -159,7 +155,7 @@ sub tested_ok_but_not_installed {
||
$self->{install}->failed
)
- );
+ );
}
@@ -186,18 +182,13 @@ sub color_cmd_tmps {
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
my $prereq_pm = $self->prereq_pm;
if (defined $prereq_pm) {
- # XXX also optional_req & optional_breq? -- xdg, 2012-04-01
- PREREQ: for my $pre (
- keys %{$prereq_pm->{requires}||{}},
- keys %{$prereq_pm->{build_requires}||{}},
- keys %{$prereq_pm->{opt_requires}||{}},
- keys %{$prereq_pm->{opt_build_requires}||{}}
- ) {
+ PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
+ keys %{$prereq_pm->{build_requires}||{}}) {
next PREREQ if $pre eq "perl";
my $premo;
unless ($premo = CPAN::Shell->expand("Module",$pre)) {
$CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
- $CPAN::Frontend->mysleep(0.2);
+ $CPAN::Frontend->mysleep(2);
next PREREQ;
}
$premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
@@ -281,66 +272,20 @@ sub called_for {
return $self->{CALLED_FOR};
}
-#-> sub CPAN::Distribution::shortcut_get ;
-# return values: undef means don't shortcut; 0 means shortcut as fail;
-# and 1 means shortcut as success
-sub shortcut_get {
- my ($self) = @_;
-
- if (my $why = $self->check_disabled) {
- $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
- # XXX why is this goodbye() instead of just print/warn?
- # Alternatively, should other print/warns here be goodbye()?
- # -- xdg, 2012-04-05
- return $self->goodbye("[disabled] -- NA $why");
- }
-
- $self->debug("checking already unwrapped[$self->{ID}]") if $CPAN::DEBUG;
- if (exists $self->{build_dir} && -d $self->{build_dir}) {
- # this deserves print, not warn:
- return $self->success("Has already been unwrapped into directory ".
- "$self->{build_dir}"
- );
- }
-
- # XXX I'm not sure this should be here because it's not really
- # a test for whether get should continue or return; this is
- # a side effect -- xdg, 2012-04-05
- $self->debug("checking missing build_dir[$self->{ID}]") if $CPAN::DEBUG;
- if (exists $self->{build_dir} && ! -d $self->{build_dir}){
- # we have lost it.
- $self->fforce(""); # no method to reset all phases but not set force (dodge)
- return undef; # no shortcut
- }
-
- # although we talk about 'force' we shall not test on
- # force directly. New model of force tries to refrain from
- # direct checking of force.
- $self->debug("checking unwrapping error[$self->{ID}]") if $CPAN::DEBUG;
- if ( exists $self->{unwrapped} and (
- UNIVERSAL::can($self->{unwrapped},"failed") ?
- $self->{unwrapped}->failed :
- $self->{unwrapped} =~ /^NO/ )
- ) {
- return $self->goodbye("Unwrapping had some problem, won't try again without force");
- }
-
- return undef; # no shortcut
-}
-
#-> sub CPAN::Distribution::get ;
sub get {
my($self) = @_;
-
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
+ $CPAN::Frontend->mywarn
+ (sprintf(
+ "delegating to '%s' as specified in prefs file '%s' doc %d\n",
+ $goto,
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ ));
return $self->goto($goto);
}
-
- if ( defined( my $sc = $self->shortcut_get) ) {
- return $sc;
- }
-
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
@@ -348,38 +293,73 @@ sub get {
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
+ EXCUSE: {
+ my @e;
+ my $goodbye_message;
+ $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
+ if ($self->prefs->{disabled} && ! $self->{force_update}) {
+ my $why = sprintf(
+ "Disabled via prefs file '%s' doc %d",
+ $self->{prefs_file},
+ $self->{prefs_file_doc},
+ );
+ push @e, $why;
+ $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
+ $goodbye_message = "[disabled] -- NA $why";
+ # note: not intended to be persistent but at least visible
+ # during this session
+ } else {
+ if (exists $self->{build_dir} && -d $self->{build_dir}
+ && ($self->{modulebuild}||$self->{writemakefile})
+ ) {
+ # this deserves print, not warn:
+ $CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
+ "$self->{build_dir}\n"
+ );
+ return 1;
+ }
+
+ # although we talk about 'force' we shall not test on
+ # force directly. New model of force tries to refrain from
+ # direct checking of force.
+ exists $self->{unwrapped} and (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )
+ and push @e, "Unwrapping had some problem, won't try again without force";
+ }
+ if (@e) {
+ $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
+ if ($goodbye_message) {
+ $self->goodbye($goodbye_message);
+ }
+ return;
+ }
+ }
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
my($local_file);
- # XXX I don't think this check needs to be here, as it
- # is already checked in shortcut_get() -- xdg, 2012-04-05
unless ($self->{build_dir} && -d $self->{build_dir}) {
$self->get_file_onto_local_disk;
return if $CPAN::Signal;
$self->check_integrity;
return if $CPAN::Signal;
(my $packagedir,$local_file) = $self->run_preps_on_packagedir;
- # XXX why is this check here? -- xdg, 2012-04-08
if (exists $self->{writemakefile} && ref $self->{writemakefile}
&& $self->{writemakefile}->can("failed") &&
$self->{writemakefile}->failed) {
- #
return;
}
$packagedir ||= $self->{build_dir};
$self->{build_dir} = $packagedir;
}
- # XXX should this move up to after run_preps_on_packagedir?
- # Otherwise, failing writemakefile can return without
- # a $CPAN::Signal check -- xdg, 2012-04-05
if ($CPAN::Signal) {
$self->safe_chdir($sub_wd);
return;
}
- return unless $self->patch;
- $self->store_persistent_state;
- return 1; # success
+ return $self->choose_MM_or_MB($local_file);
}
#-> CPAN::Distribution::get_file_onto_local_disk
@@ -521,10 +501,6 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
$from_dir = File::Spec->curdir;
@dirents = @readdir;
}
- eval { File::Path::mkpath $builddir; };
- if ($@) {
- $CPAN::Frontend->mydie("Cannot create directory $builddir: $@");
- }
$packagedir = File::Temp::tempdir(
"$tdir_base-XXXXXX",
DIR => $builddir,
@@ -533,8 +509,8 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
chmod 0777 &~ umask, $packagedir; # may fail
my $f;
for $f (@dirents) { # is already without "." and ".."
- my $from = File::Spec->catfile($from_dir,$f);
- my $to = File::Spec->catfile($packagedir,$f);
+ my $from = File::Spec->catdir($from_dir,$f);
+ my $to = File::Spec->catdir($packagedir,$f);
unless (File::Copy::move($from,$to)) {
my $err = $!;
$from = File::Spec->rel2abs($from);
@@ -599,35 +575,6 @@ EOF
return($packagedir,$local_file);
}
-#-> sub CPAN::Distribution::pick_meta_file ;
-sub pick_meta_file {
- my($self, $filter) = @_;
- $filter = '.' unless defined $filter;
-
- my $build_dir;
- unless ($build_dir = $self->{build_dir}) {
- # maybe permission on build_dir was missing
- $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
- return;
- }
-
- my $has_cm = $CPAN::META->has_usable("CPAN::Meta");
- my $has_pcm = $CPAN::META->has_usable("Parse::CPAN::Meta");
-
- my @choices;
- push @choices, 'MYMETA.json' if $has_cm;
- push @choices, 'MYMETA.yml' if $has_cm || $has_pcm;
- push @choices, 'META.json' if $has_cm;
- push @choices, 'META.yml' if $has_cm || $has_pcm;
-
- for my $file ( grep { /$filter/ } @choices ) {
- my $path = File::Spec->catfile( $build_dir, $file );
- return $path if -f $path
- }
-
- return;
-}
-
#-> sub CPAN::Distribution::parse_meta_yml ;
sub parse_meta_yml {
my($self, $yaml) = @_;
@@ -639,7 +586,6 @@ sub parse_meta_yml {
my $early_yaml;
eval {
$CPAN::META->has_inst("Parse::CPAN::Meta") or die;
- die "Parse::CPAN::Meta yaml too old" unless $Parse::CPAN::Meta::VERSION >= "1.40";
# P::C::M returns last document in scalar context
$early_yaml = Parse::CPAN::Meta::LoadFile($yaml);
};
@@ -652,8 +598,6 @@ sub parse_meta_yml {
}
#-> sub CPAN::Distribution::satisfy_requires ;
-# return values: 1 means requirements are satisfied;
-# and 0 means not satisfied (and maybe queued)
sub satisfy_requires {
my ($self) = @_;
$self->debug("Entering satisfy_requires") if $CPAN::DEBUG;
@@ -671,19 +615,18 @@ sub satisfy_requires {
my $follow = eval { $self->follow_prereqs("later",@prereq); };
if (0) {
} elsif ($follow) {
- return; # we need deps
+ # signal success to the queuerunner
+ return 1;
} elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
$CPAN::Frontend->mywarn($@);
die "[depend] -- NOT OK\n";
}
}
}
- return 1;
+ return;
}
#-> sub CPAN::Distribution::satisfy_configure_requires ;
-# return values: 1 means configure_require is satisfied;
-# and 0 means not satisfied (and maybe queued)
sub satisfy_configure_requires {
my($self) = @_;
$self->debug("Entering satisfy_configure_requires") if $CPAN::DEBUG;
@@ -695,21 +638,20 @@ sub satisfy_configure_requires {
# configure_requires simply fail, all others succeed
}
my @prereq = $self->unsat_prereq("configure_requires_later");
- $self->debug(sprintf "configure_requires[%s]", join(",",map {join "/",@$_} @prereq)) if $CPAN::DEBUG;
+ $self->debug("configure_requires[@prereq]") if $CPAN::DEBUG;
return 1 unless @prereq;
$self->debug(\@prereq) if $CPAN::DEBUG;
if ($self->{configure_requires_later}) {
for my $k (keys %{$self->{configure_requires_later_for}||{}}) {
if ($self->{configure_requires_later_for}{$k}>1) {
- my $type = "";
- for my $p (@prereq) {
- if ($p->[0] eq $k) {
- $type = $p->[1];
- }
- }
- $type = " $type" if $type;
- $CPAN::Frontend->mywarn("Warning: unmanageable(?) prerequisite $k$type");
- sleep 1;
+ # we must not come here a second time
+ $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate...");
+ require YAML::Syck;
+ $CPAN::Frontend->mydie
+ (
+ YAML::Syck::Dump
+ ({self=>$self, prereq=>\@prereq})
+ );
}
}
}
@@ -726,7 +668,7 @@ sub satisfy_configure_requires {
};
if (0) {
} elsif ($follow) {
- return; # we need deps
+ return;
} elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
$CPAN::Frontend->mywarn($@);
return $self->goodbye("[depend] -- NOT OK");
@@ -740,9 +682,8 @@ sub satisfy_configure_requires {
#-> sub CPAN::Distribution::choose_MM_or_MB ;
sub choose_MM_or_MB {
- my($self) = @_;
+ my($self,$local_file) = @_;
$self->satisfy_configure_requires() or return;
- my $local_file = $self->{localfile};
my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
my($mpl_exists) = -f $mpl;
unless ($mpl_exists) {
@@ -762,7 +703,7 @@ sub choose_MM_or_MB {
$prefer_installer = CPAN::HandleConfig->prefs_lookup(
$self, q{prefer_installer}
);
- # M::B <= 0.35 left a DATA handle open that
+ # M::B <= 0.35 left a DATA handle open that
# causes problems upgrading M::B on Windows
close *Module::Build::Version::DATA
if fileno *Module::Build::Version::DATA;
@@ -771,6 +712,7 @@ sub choose_MM_or_MB {
$prefer_installer = "mb";
}
}
+ return unless $self->patch;
if (lc($prefer_installer) eq "rand") {
$prefer_installer = rand()<.5 ? "eumm" : "mb";
}
@@ -793,19 +735,12 @@ sub choose_MM_or_MB {
return $self;
}
-# see also reanimate_build_dir
#-> CPAN::Distribution::store_persistent_state
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
- unless (defined $dir && length $dir) {
- my $id = $self->id;
- $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
- "will not store persistent state\n");
- return;
- }
- unless ( Cwd::realpath(File::Spec->catdir($dir, File::Spec->updir()) )
- eq Cwd::realpath($CPAN::Config->{build_dir} ) ) {
+ unless (File::Spec->canonpath(File::Basename::dirname($dir))
+ eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not store persistent state\n");
return;
@@ -886,7 +821,7 @@ sub try_download {
}
}
my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
- $CPAN::Frontend->myprint("Applying $countedpatches:\n");
+ $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
my $patches_dir = $CPAN::Config->{patches_dir};
for my $patch (@$patches) {
if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
@@ -909,20 +844,12 @@ sub try_download {
my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
my $pcommand;
- my($ppp,$pfiles) = $self->_patch_p_parameter($readfh);
+ my $ppp = $self->_patch_p_parameter($readfh);
if ($ppp eq "applypatch") {
$pcommand = "$CPAN::Config->{applypatch} -verbose";
} else {
my $thispatchargs = join " ", $stdpatchargs, $ppp;
$pcommand = "$patchbin $thispatchargs";
- require Config; # usually loaded from CPAN.pm
- if ($Config::Config{osname} eq "solaris") {
- # native solaris patch cannot patch readonly files
- for my $file (@{$pfiles||[]}) {
- my @stat = stat $file or next;
- chmod $stat[2] | 0600, $file; # may fail
- }
- }
}
$readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
@@ -953,14 +880,10 @@ sub try_download {
}
}
-# may return
-# - "applypatch"
-# - ("-p0"|"-p1", $files)
sub _patch_p_parameter {
my($self,$fh) = @_;
my $cnt_files = 0;
my $cnt_p0files = 0;
- my @files;
local($_);
while ($_ = $fh->READLINE) {
if (
@@ -972,15 +895,13 @@ sub _patch_p_parameter {
}
next unless /^[\*\+]{3}\s(\S+)/;
my $file = $1;
- push @files, $file;
$cnt_files++;
$cnt_p0files++ if -f $file;
CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
if $CPAN::DEBUG;
}
return "-p1" unless $cnt_files;
- my $opt_p = $cnt_files==$cnt_p0files ? "-p0" : "-p1";
- return ($opt_p, \@files);
+ return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
}
#-> sub CPAN::Distribution::_edge_cases
@@ -1079,7 +1000,7 @@ sub _exefile_stanza {
$fh->open($script_file)
or Carp::croak("Could not open script '$script_file': $!");
local $/ = "\n";
- # parse name and prereq
+ # name parsen und prereq
my($state) = "poddir";
my($name, $prereq) = ("", "");
while (<$fh>) {
@@ -1194,7 +1115,6 @@ sub untar_me {
if ($result) {
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
- # unfortunately we have no $@ here, Tarzip is using mydie which dies with "\n"
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
}
}
@@ -1736,78 +1656,48 @@ sub perl {
return CPAN::HandleConfig->safe_quote($CPAN::Perl);
}
-#-> sub CPAN::Distribution::shortcut_prepare ;
-# return values: undef means don't shortcut; 0 means shortcut as fail;
-# and 1 means shortcut as success
-sub shortcut_prepare {
- my ($self) = @_;
-
- $self->debug("checking archive type[$self->{ID}]") if $CPAN::DEBUG;
- if (!$self->{archived} || $self->{archived} eq "NO") {
- return $self->goodbye("Is neither a tar nor a zip archive.");
- }
-
- $self->debug("checking unwrapping[$self->{ID}]") if $CPAN::DEBUG;
- if (!$self->{unwrapped}
- || (
- UNIVERSAL::can($self->{unwrapped},"failed") ?
- $self->{unwrapped}->failed :
- $self->{unwrapped} =~ /^NO/
- )) {
- return $self->goodbye("Had problems unarchiving. Please build manually");
- }
-
- $self->debug("checking signature[$self->{ID}]") if $CPAN::DEBUG;
- if ( ! $self->{force_update}
- && exists $self->{signature_verify}
- && (
- UNIVERSAL::can($self->{signature_verify},"failed") ?
- $self->{signature_verify}->failed :
- $self->{signature_verify} =~ /^NO/
- )
- ) {
- return $self->goodbye("Did not pass the signature test.");
+#-> sub CPAN::Distribution::make ;
+sub make {
+ my($self) = @_;
+ if (my $goto = $self->prefs->{goto}) {
+ return $self->goto($goto);
}
-
- $self->debug("checking writemakefile[$self->{ID}]") if $CPAN::DEBUG;
- if ($self->{writemakefile}) {
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ # Emergency brake if they said install Pippi and get newest perl
+ if ($self->isa_perl) {
if (
- UNIVERSAL::can($self->{writemakefile},"failed") ?
- $self->{writemakefile}->failed :
- $self->{writemakefile} =~ /^NO/
- ) {
- # XXX maybe a retry would be in order?
- my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
- $self->{writemakefile}->text :
- $self->{writemakefile};
- $err =~ s/^NO\s*(--\s+)?//;
- $err ||= "Had some problem writing Makefile";
- $err .= ", not re-running";
- return $self->goodbye($err);
- } else {
- return $self->success("Has already been prepared");
+ $self->called_for ne $self->id &&
+ ! $self->{force_update}
+ ) {
+ # if we die here, we break bundles
+ $CPAN::Frontend
+ ->mywarn(sprintf(
+ qq{The most recent version "%s" of the module "%s"
+is part of the perl-%s distribution. To install that, you need to run
+ force install %s --or--
+ install %s
+},
+ $CPAN::META->instance(
+ 'CPAN::Module',
+ $self->called_for
+ )->cpan_version,
+ $self->called_for,
+ $self->isa_perl,
+ $self->called_for,
+ $self->id,
+ ));
+ $self->{make} = CPAN::Distrostatus->new("NO isa perl");
+ $CPAN::Frontend->mysleep(1);
+ return;
}
}
-
- $self->debug("checking configure_requires_later[$self->{ID}]") if $CPAN::DEBUG;
- if( my $later = $self->{configure_requires_later} ) { # see also undelay
- return $self->goodbye($later);
- }
-
- return undef; # no shortcut
-}
-
-sub prepare {
- my ($self) = @_;
-
- $self->get
- or return;
-
- if ( defined( my $sc = $self->shortcut_prepare) ) {
- return $sc;
+ $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
+ $self->get;
+ return if $self->prefs->{disabled} && ! $self->{force_update};
+ if ($self->{configure_requires_later}) {
+ return;
}
-
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
@@ -1820,46 +1710,112 @@ sub prepare {
return;
}
- my $builddir = $self->dir or
- $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+ my $builddir;
+ EXCUSE: {
+ my @e;
+ if (!$self->{archived} || $self->{archived} eq "NO") {
+ push @e, "Is neither a tar nor a zip archive.";
+ }
+
+ if (!$self->{unwrapped}
+ || (
+ UNIVERSAL::can($self->{unwrapped},"failed") ?
+ $self->{unwrapped}->failed :
+ $self->{unwrapped} =~ /^NO/
+ )) {
+ push @e, "Had problems unarchiving. Please build manually";
+ }
- unless (chdir $builddir) {
- $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
- return;
- }
+ unless ($self->{force_update}) {
+ exists $self->{signature_verify} and
+ (
+ UNIVERSAL::can($self->{signature_verify},"failed") ?
+ $self->{signature_verify}->failed :
+ $self->{signature_verify} =~ /^NO/
+ )
+ and push @e, "Did not pass the signature test.";
+ }
+
+ if (exists $self->{writemakefile} &&
+ (
+ UNIVERSAL::can($self->{writemakefile},"failed") ?
+ $self->{writemakefile}->failed :
+ $self->{writemakefile} =~ /^NO/
+ )) {
+ # XXX maybe a retry would be in order?
+ my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
+ $self->{writemakefile}->text :
+ $self->{writemakefile};
+ $err =~ s/^NO\s*(--\s+)?//;
+ $err ||= "Had some problem writing Makefile";
+ $err .= ", won't make";
+ push @e, $err;
+ }
+
+ if (defined $self->{make}) {
+ if (UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/) {
+ if ($self->{force_update}) {
+ # Trying an already failed 'make' (unless somebody else blocks)
+ } else {
+ # introduced for turning recursion detection into a distrostatus
+ my $error = length $self->{make}>3
+ ? substr($self->{make},3) : "Unknown error";
+ $CPAN::Frontend->mywarn("Could not make: $error\n");
+ $self->store_persistent_state;
+ return;
+ }
+ } else {
+ push @e, "Has already been made";
+ my $wait_for_prereqs = eval { $self->satisfy_requires };
+ return 1 if $wait_for_prereqs; # tells queuerunner to continue
+ return $self->goodbye($@) if $@; # tells queuerunner to stop
+ }
+ }
+
+ my $later = $self->{later} || $self->{configure_requires_later};
+ if ($later) { # see also undelay
+ if ($later) {
+ push @e, $later;
+ }
+ }
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+ unless (chdir $builddir) {
+ push @e, "Couldn't chdir to '$builddir': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ }
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
-
+ $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
- local $ENV{PERL_AUTOINSTALL} = $ENV{PERL_AUTOINSTALL};
- local $ENV{PERL_EXTUTILS_AUTOINSTALL} = $ENV{PERL_EXTUTILS_AUTOINSTALL};
- $self->choose_MM_or_MB
- or return;
-
- my $configurator = $self->{configure} ? "Configure"
- : $self->{modulebuild} ? "Build.PL"
- : "Makefile.PL";
-
- $CPAN::Frontend->myprint("Configuring ".$self->id." with $configurator\n");
+ if ($^O eq 'MacOS') {
+ Mac::BuildTools::make($self);
+ return;
+ }
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
if ($CPAN::Config->{prerequisites_policy} eq "follow") {
$ENV{PERL_AUTOINSTALL} ||= "--defaultdeps";
$ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps";
}
-
my $system;
my $pl_commandline;
if ($self->prefs->{pl}) {
$pl_commandline = $self->prefs->{pl}{commandline};
}
- local $ENV{PERL} = $ENV{PERL};
- local $ENV{PERL5_CPAN_IS_EXECUTING} = $ENV{PERL5_CPAN_IS_EXECUTING};
- local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
- local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
if ($pl_commandline) {
$system = $pl_commandline;
$ENV{PERL} = $^X;
@@ -1867,11 +1823,7 @@ sub prepare {
$system = $self->{'configure'};
} elsif ($self->{modulebuild}) {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
- my $mbuildpl_arg = $self->_make_phase_arg("pl");
- $system = sprintf("%s Build.PL%s",
- $perl,
- $mbuildpl_arg ? " $mbuildpl_arg" : "",
- );
+ $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
} else {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
my $switch = "";
@@ -1892,7 +1844,11 @@ sub prepare {
if ($self->prefs->{pl}) {
$pl_env = $self->prefs->{pl}{env};
}
- local @ENV{keys %$pl_env} = values %$pl_env if $pl_env;
+ if ($pl_env) {
+ for my $e (keys %$pl_env) {
+ $ENV{$e} = $pl_env->{$e};
+ }
+ }
if (exists $self->{writemakefile}) {
} else {
local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
@@ -1984,11 +1940,9 @@ sub prepare {
return $self->goodbye("$system -- NOT OK");
}
}
- if (-f "Makefile" || -f "Build" || ($^O eq 'VMS' && (-f 'descrip.mms' || -f 'Build.com'))) {
+ if (-f "Makefile" || -f "Build") {
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
delete $self->{make_clean}; # if cleaned before, enable next
- $self->store_persistent_state;
- return $self->success("$system -- OK");
} else {
my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
my $why = "No '$makefile' created";
@@ -1999,151 +1953,27 @@ sub prepare {
return $self->goodbye("$system -- NOT OK");
}
}
- $self->store_persistent_state;
- return 1; # success
-}
-
-#-> sub CPAN::Distribution::shortcut_make ;
-# return values: undef means don't shortcut; 0 means shortcut as fail;
-# and 1 means shortcut as success
-sub shortcut_make {
- my ($self) = @_;
-
- $self->debug("checking make/build results[$self->{ID}]") if $CPAN::DEBUG;
- if (defined $self->{make}) {
- if (UNIVERSAL::can($self->{make},"failed") ?
- $self->{make}->failed :
- $self->{make} =~ /^NO/
- ) {
- if ($self->{force_update}) {
- # Trying an already failed 'make' (unless somebody else blocks)
- return undef; # no shortcut
- } else {
- # introduced for turning recursion detection into a distrostatus
- my $error = length $self->{make}>3
- ? substr($self->{make},3) : "Unknown error";
- $self->store_persistent_state;
- return $self->goodbye("Could not make: $error\n");
- }
- } else {
- return $self->success("Has already been made")
- }
- }
- return undef; # no shortcut
-}
-
-#-> sub CPAN::Distribution::make ;
-sub make {
- my($self) = @_;
-
- $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
- if (my $goto = $self->prefs->{goto}) {
- return $self->goto($goto);
- }
- # Emergency brake if they said install Pippi and get newest perl
-
- # XXX Would this make more sense in shortcut_prepare, since
- # that doesn't make sense on a perl dist either? Broader
- # question: what is the purpose of suggesting force install
- # on a perl distribution? That seems unlikely to result in
- # such a dependency being satisfied, even if the perl is
- # successfully installed. This situation is tantamount to
- # a prereq on a version of perl greater than the current one
- # so I think we should just abort. -- xdg, 2012-04-06
- if ($self->isa_perl) {
- if (
- $self->called_for ne $self->id &&
- ! $self->{force_update}
- ) {
- # if we die here, we break bundles
- $CPAN::Frontend
- ->mywarn(sprintf(
- qq{The most recent version "%s" of the module "%s"
-is part of the perl-%s distribution. To install that, you need to run
- force install %s --or--
- install %s
-},
- $CPAN::META->instance(
- 'CPAN::Module',
- $self->called_for
- )->cpan_version,
- $self->called_for,
- $self->isa_perl,
- $self->called_for,
- $self->id,
- ));
- $self->{make} = CPAN::Distrostatus->new("NO isa perl");
- $CPAN::Frontend->mysleep(1);
- return;
- }
- }
-
- $self->prepare
- or return;
-
- if ( defined( my $sc = $self->shortcut_make) ) {
- return $sc;
- }
-
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
-
- my $builddir = $self->dir or
- $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
-
- unless (chdir $builddir) {
- $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
- return;
- }
-
- my $make = $self->{modulebuild} ? "Build" : "make";
- $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
- local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
- ? $ENV{PERL5LIB}
- : ($ENV{PERLLIB} || "");
- local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
- $CPAN::META->set_perl5lib;
- local $ENV{MAKEFLAGS}; # protect us from outer make calls
-
- if ($CPAN::Signal) {
- delete $self->{force_update};
- return;
- }
-
- if ($^O eq 'MacOS') {
- Mac::BuildTools::make($self);
- return;
- }
-
- my %env;
- while (my($k,$v) = each %ENV) {
- next unless defined $v;
- $env{$k} = $v;
- }
- local %ENV = %env;
- my $satisfied = eval { $self->satisfy_requires };
- return $self->goodbye($@) if $@;
- return unless $satisfied ;
+ my $wait_for_prereqs = eval { $self->satisfy_requires };
+ return 1 if $wait_for_prereqs; # tells queuerunner to continue
+ return $self->goodbye($@) if $@; # tells queuerunner to stop
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
- my $system;
my $make_commandline;
if ($self->prefs->{make}) {
$make_commandline = $self->prefs->{make}{commandline};
}
- local $ENV{PERL} = $ENV{PERL};
- local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
- local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
if ($make_commandline) {
$system = $make_commandline;
$ENV{PERL} = CPAN::find_perl();
} else {
if ($self->{modulebuild}) {
- unless (-f "Build" || ($^O eq 'VMS' && -f 'Build.com')) {
+ unless (-f "Build") {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
" in cwd[$cwd]. Danger, Will Robinson!\n");
@@ -2164,7 +1994,12 @@ is part of the perl-%s distribution. To install that, you need to run
if ($self->prefs->{make}) {
$make_env = $self->prefs->{make}{env};
}
- local @ENV{keys %$make_env} = values %$make_env if $make_env;
+ if ($make_env) { # overriding the local ENV of PL, not the outer
+ # ENV, but unlikely to be a risk
+ for my $e (keys %$make_env) {
+ $ENV{$e} = $make_env->{$e};
+ }
+ }
my $expect_model = $self->_prefs_with_expect("make");
my $want_expect = 0;
if ( $expect_model && @{$expect_model->{talk}} ) {
@@ -2200,7 +2035,6 @@ is part of the perl-%s distribution. To install that, you need to run
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
}
$self->store_persistent_state;
- return !! $system_ok;
}
# CPAN::Distribution::goodbye ;
@@ -2208,14 +2042,7 @@ sub goodbye {
my($self,$goodbye) = @_;
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn(" $id\n $goodbye\n");
- return 0; # must be explicit false, not undef
-}
-
-sub success {
- my($self,$why) = @_;
- my $id = $self->pretty_id;
- $CPAN::Frontend->myprint(" $id\n $why\n");
- return 1;
+ return;
}
# CPAN::Distribution::_run_via_expect ;
@@ -2563,30 +2390,6 @@ sub _make_command {
}
}
-sub _make_install_make_command {
- my ($self) = @_;
- my $mimc =
- CPAN::HandleConfig->prefs_lookup($self, q{make_install_make_command});
- return $self->_make_command() unless $mimc;
-
- # Quote the "make install" make command on Windows, where it is commonly
- # found in, e.g., C:\Program Files\... and therefore needs quoting. We can't
- # do this in general because the command maybe "sudo make..." (i.e. a
- # program with arguments), but that is unlikely to be the case on Windows.
- $mimc = CPAN::HandleConfig->safe_quote($mimc) if $^O eq 'MSWin32';
-
- return $mimc;
-}
-
-#-> sub CPAN::Distribution::is_locally_optional
-sub is_locally_optional {
- my($self, $prereq_pm, $prereq) = @_;
- $prereq_pm ||= $self->{prereq_pm};
- exists $prereq_pm->{opt_requires}{$prereq}
- ||
- exists $prereq_pm->{opt_build_requires}{$prereq};
-}
-
#-> sub CPAN::Distribution::follow_prereqs ;
sub follow_prereqs {
my($self) = shift;
@@ -2595,20 +2398,8 @@ sub follow_prereqs {
return unless @prereq_tuples;
my(@good_prereq_tuples);
for my $p (@prereq_tuples) {
- # e.g. $p = ['Devel::PartialDump', 'r', 1]
- # promote if possible
- if ($p->[1] =~ /^(r|c)$/) {
- push @good_prereq_tuples, $p;
- } elsif ($p->[1] =~ /^(b)$/) {
- my $reqtype = CPAN::Queue->reqtype_of($p->[0]);
- if ($reqtype =~ /^(r|c)$/) {
- push @good_prereq_tuples, [$p->[0], $reqtype, $p->[2]];
- } else {
- push @good_prereq_tuples, $p;
- }
- } else {
- die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen";
- }
+ # XXX watch out for foul ones
+ push @good_prereq_tuples, $p;
}
my $pretty_id = $self->pretty_id;
my %map = (
@@ -2634,7 +2425,7 @@ sub follow_prereqs {
$CPAN::Frontend->
myprint("$filler1 $unsat $filler2".
"$filler3 $pretty_id $filler4".
- join("", map {sprintf " %s \[%s%s]\n", $_->[0], $map{$_->[1]}, $self->is_locally_optional(undef,$_->[0]) ? ",optional" : ""} @good_prereq_tuples),
+ join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
);
my $follow = 0;
if ($CPAN::Config->{prerequisites_policy} eq "follow") {
@@ -2645,49 +2436,31 @@ sub follow_prereqs {
of modules we are processing right now?", "yes");
$follow = $answer =~ /^\s*y/i;
} else {
- my @prereq = map { $_->[0] } @good_prereq_tuples;
+ my @prereq = map { $_=>[0] } @good_prereq_tuples;
local($") = ", ";
$CPAN::Frontend->
myprint(" Ignoring dependencies on modules @prereq\n");
}
if ($follow) {
my $id = $self->id;
- my(@to_queue_mand,@to_queue_opt);
+ # color them as dirty
for my $gp (@good_prereq_tuples) {
- my($prereq,$reqtype,$optional) = @$gp;
- my $qthing = +{qmod=>$prereq,reqtype=>$reqtype,optional=>$optional};
- if ($optional &&
- $self->is_locally_optional(undef,$prereq)
- ){
- # Since we do not depend on this one, we do not need
- # this in a mandatory arrangement:
- push @to_queue_opt, $qthing;
+ # warn "calling color_cmd_tmps(0,1)";
+ my $p = $gp->[0];
+ my $any = CPAN::Shell->expandany($p);
+ $self->{$slot . "_for"}{$any->id}++;
+ if ($any) {
+ $any->color_cmd_tmps(0,2);
} else {
- my $any = CPAN::Shell->expandany($prereq);
- $self->{$slot . "_for"}{$any->id}++;
- if ($any) {
- unless ($optional) {
- # No recursion check in an optional area of the tree
- $any->color_cmd_tmps(0,2);
- }
- } else {
- $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$prereq'\n");
- $CPAN::Frontend->mysleep(2);
- }
- # order everything that is not locally_optional just
- # like mandatory items: this keeps leaves before
- # branches
- unshift @to_queue_mand, $qthing;
+ $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
+ $CPAN::Frontend->mysleep(2);
}
}
- if (@to_queue_mand) {
- unshift @to_queue_mand, {qmod => $id, reqtype => $self->{reqtype}, optional=> !$self->{mandatory}};
- CPAN::Queue->jumpqueue(@to_queue_opt,@to_queue_mand);
- $self->{$slot} = "Delayed until after prerequisites";
- return 1; # signal we need dependencies
- } elsif (@to_queue_opt) {
- CPAN::Queue->jumpqueue(@to_queue_opt);
- }
+ # queue them and re-queue yourself
+ CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
+ map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
+ $self->{$slot} = "Delayed until after prerequisites";
+ return 1; # signal success to the queuerunner
}
return;
}
@@ -2730,24 +2503,29 @@ sub _feature_depends {
$dep;
}
-sub prereqs_for_slot {
+#-> sub CPAN::Distribution::unsat_prereq ;
+# return ([Foo,"r"],[Bar,"b"]) for normal modules
+# return ([perl=>5.008]) if we need a newer perl than we are running under
+# (sorry for the inconsistency, it was an accident)
+sub unsat_prereq {
my($self,$slot) = @_;
- my($prereq_pm);
- my $merged = CPAN::Meta::Requirements->new;
+ my(%merged,$prereq_pm);
my $prefs_depends = $self->prefs->{depends}||{};
my $feature_depends = $self->_feature_depends();
if ($slot eq "configure_requires_later") {
- for my $hash ( $self->configure_requires,
- $prefs_depends->{configure_requires},
- $feature_depends->{configure_requires},
- ) {
- $merged->add_requirements(
- CPAN::Meta::Requirements->from_string_hash($hash)
- );
- }
+ my $meta_yml = $self->parse_meta_yml();
+ if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) {
+ $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n");
+ $meta_yml = +{};
+ }
+ %merged = (
+ %{$meta_yml->{configure_requires}||{}},
+ %{$prefs_depends->{configure_requires}||{}},
+ %{$feature_depends->{configure_requires}||{}},
+ );
if (-f "Build.PL"
- && ! -f File::Spec->catfile($self->{build_dir},"Makefile.PL")
- && ! $merged->requirements_for_module("Module::Build")
+ && ! -f "Makefile.PL"
+ && ! exists $merged{"Module::Build"}
&& ! $CPAN::META->has_inst("Module::Build")
) {
$CPAN::Frontend->mywarn(
@@ -2755,13 +2533,13 @@ sub prereqs_for_slot {
" Adding it now as such.\n"
);
$CPAN::Frontend->mysleep(5);
- $merged->add_minimum( "Module::Build" => 0 );
+ $merged{"Module::Build"} = 0;
delete $self->{writemakefile};
}
$prereq_pm = {}; # configure_requires defined as "b"
} elsif ($slot eq "later") {
my $prereq_pm_0 = $self->prereq_pm || {};
- for my $reqtype (qw(requires build_requires opt_requires opt_build_requires)) {
+ for my $reqtype (qw(requires build_requires)) {
$prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
for my $dep ($prefs_depends,$feature_depends) {
for my $k (keys %{$dep->{$reqtype}||{}}) {
@@ -2769,37 +2547,14 @@ sub prereqs_for_slot {
}
}
}
- # XXX what about optional_req|breq? -- xdg, 2012-04-01
- for my $hash (
- $prereq_pm->{requires},
- $prereq_pm->{build_requires},
- $prereq_pm->{opt_requires},
- $prereq_pm->{opt_build_requires},
-
- ) {
- $merged->add_requirements(
- CPAN::Meta::Requirements->from_string_hash($hash)
- );
- }
+ %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
} else {
die "Panic: illegal slot '$slot'";
}
- return ($merged->as_string_hash, $prereq_pm);
-}
-
-#-> sub CPAN::Distribution::unsat_prereq ;
-# return ([Foo,"r"],[Bar,"b"]) for normal modules
-# return ([perl=>5.008]) if we need a newer perl than we are running under
-# (sorry for the inconsistency, it was an accident)
-sub unsat_prereq {
- my($self,$slot) = @_;
- my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot);
my(@need);
- my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
- my @merged = $merged->required_modules;
+ my @merged = %merged;
CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
- NEED: for my $need_module ( @merged ) {
- my $need_version = $merged->requirements_for_module($need_module);
+ NEED: while (my($need_module, $need_version) = each %merged) {
my($available_version,$inst_file,$available_file,$nmo);
if ($need_module eq "perl") {
$available_version = $];
@@ -2816,14 +2571,15 @@ sub unsat_prereq {
# if they have not specified a version, we accept any installed one
if ( $available_file
- and ( # a few quick short circuits
+ and ( # a few quick shortcurcuits
not defined $need_version
or $need_version eq '0' # "==" would trigger warning when not numeric
or $need_version eq "undef"
)) {
- unless ($nmo->inst_deprecated) {
- next NEED;
- }
+ unless ($nmo->inst_deprecated) {
+ next NEED;
+ }
+
}
$available_version = $nmo->available_version;
@@ -2837,51 +2593,13 @@ sub unsat_prereq {
# one and is deprecated
if ( $available_file ) {
- my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
- (
- $need_module,
- $available_file,
- $available_version,
- $need_version,
- );
- if ( $inst_file
- && $available_file eq $inst_file
- && $nmo->inst_deprecated
- ) {
- # continue installing as a prereq. we really want that
- # because the deprecated module may spit out warnings
- # and third party did not know until today. Only one
- # exception is OK, because CPANPLUS is special after
- # all:
- if ( $fulfills_all_version_rqs and
- $nmo->id =~ /^CPANPLUS(?:::Dist::Build)$/
- ) {
- # here we have an available version that is good
- # enough although deprecated (preventing circular
- # loop CPANPLUS => CPANPLUS::Dist::Build RT#83042)
- next NEED;
- }
- } elsif (
- $self->{reqtype} =~ /^(r|c)$/
- && (exists $prereq_pm->{requires}{$need_module} || exists $prereq_pm->{opt_requires} )
- && $nmo
- && !$inst_file
- ) {
- # continue installing as a prereq; this may be a
- # distro we already used when it was a build_requires
- # so we did not install it. But suddenly somebody
- # wants it as a requires
- my $need_distro = $nmo->distribution;
- if ($need_distro->{install} && $need_distro->{install}->failed && $need_distro->{install}->text =~ /is only/) {
- CPAN->debug("promotion from build_requires to requires") if $CPAN::DEBUG;
- delete $need_distro->{install}; # promote to another installation attempt
- $need_distro->{reqtype} = "r";
- $need_distro->install;
- next NEED;
- }
+ if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) {
+ # continue installing as a prereq
}
else {
- next NEED if $fulfills_all_version_rqs;
+ next NEED if $self->_fulfills_all_version_rqs(
+ $need_module,$available_file,$available_version,$need_version
+ );
}
}
@@ -2950,20 +2668,14 @@ sub unsat_prereq {
) {
next NOSAYER;
}
- ### XXX don't complain about missing optional deps -- xdg, 2012-04-01
- if ($self->is_locally_optional($prereq_pm, $need_module)) {
- # don't complain about failing optional prereqs
- }
- else {
- $CPAN::Frontend->mywarn("Warning: Prerequisite ".
- "'$need_module => $need_version' ".
- "for '$selfid' failed when ".
- "processing '$did' with ".
- "'$nosayer => $do->{$nosayer}'. Continuing, ".
- "but chances to succeed are limited.\n"
- );
- $CPAN::Frontend->mysleep($sponsoring/10);
- }
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$selfid' failed when ".
+ "processing '$did' with ".
+ "'$nosayer => $do->{$nosayer}'. Continuing, ".
+ "but chances to succeed are limited.\n"
+ );
+ $CPAN::Frontend->mysleep($sponsoring/10);
next NEED;
} else { # the other guy succeeded
if ($nosayer =~ /^(install|make_test)$/) {
@@ -2971,41 +2683,21 @@ sub unsat_prereq {
# DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
# in 2007-03 for 'make install'
# and 2008-04: #30464 (for 'make test')
- # $CPAN::Frontend->mywarn("Warning: Prerequisite ".
- # "'$need_module => $need_version' ".
- # "for '$selfid' already built ".
- # "but the result looks suspicious. ".
- # "Skipping another build attempt, ".
- # "to prevent looping endlessly.\n"
- # );
+ $CPAN::Frontend->mywarn("Warning: Prerequisite ".
+ "'$need_module => $need_version' ".
+ "for '$selfid' already built ".
+ "but the result looks suspicious. ".
+ "Skipping another build attempt, ".
+ "to prevent looping endlessly.\n"
+ );
next NEED;
}
}
}
}
}
- my $needed_as;
- if (0) {
- } elsif (exists $prereq_pm->{requires}{$need_module}
- || exists $prereq_pm->{opt_requires}{$need_module}
- ) {
- $needed_as = "r";
- } elsif ($slot eq "configure_requires_later") {
- # in ae872487d5 we said: C< we have not yet run the
- # {Build,Makefile}.PL, we must presume "r" >; but the
- # meta.yml standard says C< These dependencies are not
- # required after the distribution is installed. >; so now
- # we change it back to "b" and care for the proper
- # promotion later.
- $needed_as = "b";
- } else {
- $needed_as = "b";
- }
- # here need to flag as optional for recommends/suggests
- # -- xdg, 2012-04-01
- my $optional = !$self->{mandatory}
- || $self->is_locally_optional($prereq_pm, $need_module);
- push @need, [$need_module,$needed_as,$optional];
+ my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
+ push @need, [$need_module,$needed_as];
}
my @unfolded = map { "[".join(",",@$_)."]" } @need;
CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
@@ -3066,38 +2758,27 @@ sub _fulfills_all_version_rqs {
return $ret;
}
-#-> sub CPAN::Distribution::read_meta
-# read any sort of meta files, return CPAN::Meta object if no errors
-sub read_meta {
- my($self) = @_;
- my $meta_file = $self->pick_meta_file
- or return;
-
- return unless $CPAN::META->has_usable("CPAN::Meta");
- my $meta = eval { CPAN::Meta->load_file($meta_file)}
- or return;
-
- # Very old EU::MM could have wrong META
- if ($meta_file eq 'META.yml'
- && $meta->generated_by =~ /ExtUtils::MakeMaker version ([\d\._]+)/
- ) {
- my $eummv = do { local $^W = 0; $1+0; };
- return if $eummv < 6.2501;
- }
-
- return $meta;
-}
-
#-> sub CPAN::Distribution::read_yaml ;
-# XXX This should be DEPRECATED -- dagolden, 2011-02-05
sub read_yaml {
my($self) = @_;
- my $meta_file = $self->pick_meta_file('\.yml$');
+ my $build_dir;
+ unless ($build_dir = $self->{build_dir}) {
+ # maybe permission on build_dir was missing
+ $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
+ return;
+ }
+ # if MYMETA.yml exists, that takes precedence over META.yml
+ my $meta = File::Spec->catfile($build_dir,"META.yml");
+ my $mymeta = File::Spec->catfile($build_dir,"MYMETA.yml");
+ my $meta_file = -f $mymeta ? $mymeta : $meta;
$self->debug("meta_file[$meta_file]") if $CPAN::DEBUG;
- return unless $meta_file;
+ return unless -f $meta_file;
my $yaml;
eval { $yaml = $self->parse_meta_yml($meta_file) };
if ($@ or ! $yaml) {
+ $CPAN::Frontend->mywarnonce("Could not read ".
+ "'$meta_file'. Falling back to other ".
+ "methods to determine prerequisites\n");
return undef; # if we die, then we cannot read YAML's own META.yml
}
# not "authoritative"
@@ -3109,8 +2790,8 @@ sub read_yaml {
if $CPAN::DEBUG;
$self->debug($yaml) if $CPAN::DEBUG && $yaml;
# MYMETA.yml is static and authoritative by definition
- if ( $meta_file =~ /MYMETA\.yml/ ) {
- return $yaml;
+ if ( $meta_file eq $mymeta ) {
+ return $yaml;
}
# META.yml is authoritative only if dynamic_config is defined and false
if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
@@ -3120,21 +2801,6 @@ sub read_yaml {
return undef;
}
-#-> sub CPAN::Distribution::configure_requires ;
-sub configure_requires {
- my($self) = @_;
- return unless my $meta_file = $self->pick_meta_file('^META');
- if (my $meta_obj = $self->read_meta) {
- my $prereqs = $meta_obj->effective_prereqs;
- my $cr = $prereqs->requirements_for(qw/configure requires/);
- return $cr ? $cr->as_string_hash : undef;
- }
- else {
- my $yaml = eval { $self->parse_meta_yml($meta_file) };
- return $yaml->{configure_requires};
- }
-}
-
#-> sub CPAN::Distribution::prereq_pm ;
sub prereq_pm {
my($self) = @_;
@@ -3144,50 +2810,14 @@ sub prereq_pm {
unless ($self->{build_dir}) {
return;
}
- # no Makefile/Build means configuration aborted, so don't look for prereqs
- return unless -f File::Spec->catfile($self->{build_dir},'Makefile')
- || -f File::Spec->catfile($self->{build_dir},'Build');
CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
$self->{writemakefile}||"",
$self->{modulebuild}||"",
) if $CPAN::DEBUG;
- my($req,$breq, $opt_req, $opt_breq);
- my $meta_obj = $self->read_meta;
- # META/MYMETA is only authoritative if dynamic_config is false
- if ($meta_obj && ! $meta_obj->dynamic_config) {
- my $prereqs = $meta_obj->effective_prereqs;
- my $requires = $prereqs->requirements_for(qw/runtime requires/);
- my $build_requires = $prereqs->requirements_for(qw/build requires/);
- my $test_requires = $prereqs->requirements_for(qw/test requires/);
- # XXX we don't yet distinguish build vs test, so merge them for now
- $build_requires->add_requirements($test_requires);
- $req = $requires->as_string_hash;
- $breq = $build_requires->as_string_hash;
-
- # XXX assemble optional_req && optional_breq from recommends/suggests
- # depending on corresponding policies -- xdg, 2012-04-01
- my $opt_runtime = CPAN::Meta::Requirements->new;
- my $opt_build = CPAN::Meta::Requirements->new;
- if ( $CPAN::Config->{recommends_policy} ) {
- $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime recommends/));
- $opt_build->add_requirements( $prereqs->requirements_for(qw/build recommends/));
- $opt_build->add_requirements( $prereqs->requirements_for(qw/test recommends/));
-
- }
- if ( $CPAN::Config->{suggests_policy} ) {
- $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime suggests/));
- $opt_build->add_requirements( $prereqs->requirements_for(qw/build suggests/));
- $opt_build->add_requirements( $prereqs->requirements_for(qw/test suggests/));
- }
- $opt_req = $opt_runtime->as_string_hash;
- $opt_breq = $opt_build->as_string_hash;
- }
- elsif (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
+ my($req,$breq);
+ if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
$req = $yaml->{requires} || {};
$breq = $yaml->{build_requires} || {};
- if ( $CPAN::Config->{recommends_policy} ) {
- $opt_req = $yaml->{recommends} || {};
- }
undef $req unless ref $req eq "HASH" && %$req;
if ($req) {
if ($yaml->{generated_by} &&
@@ -3203,7 +2833,6 @@ sub prereq_pm {
my $areq;
my $do_replace;
while (my($k,$v) = each %{$req||{}}) {
- next unless defined $v;
if ($v =~ /\d/) {
$areq->{$k} = $v;
} elsif ($k =~ /[A-Za-z]/ &&
@@ -3222,11 +2851,6 @@ sub prereq_pm {
$req = $areq if $do_replace;
}
}
- else {
- $CPAN::Frontend->mywarnonce("Could not read metadata file. Falling back to other ".
- "methods to determine prerequisites\n");
- }
-
unless ($req || $breq) {
my $build_dir;
unless ( $build_dir = $self->{build_dir} ) {
@@ -3294,142 +2918,29 @@ sub prereq_pm {
}
}
}
- # XXX needs to be adapted for optional_req & optional_breq -- xdg, 2012-04-01
- if ($req || $breq || $opt_req || $opt_breq ) {
- return $self->{prereq_pm} = {
- requires => $req,
- build_requires => $breq,
- opt_requires => $opt_req,
- opt_build_requires => $opt_breq,
- };
- }
-}
-
-#-> sub CPAN::Distribution::shortcut_test ;
-# return values: undef means don't shortcut; 0 means shortcut as fail;
-# and 1 means shortcut as success
-sub shortcut_test {
- my ($self) = @_;
-
- $self->debug("checking badtestcnt[$self->{ID}]") if $CPAN::DEBUG;
- $self->{badtestcnt} ||= 0;
- if ($self->{badtestcnt} > 0) {
- require Data::Dumper;
- CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
- return $self->goodbye("Won't repeat unsuccessful test during this command");
- }
-
- for my $slot ( qw/later configure_requires_later/ ) {
- $self->debug("checking $slot slot[$self->{ID}]") if $CPAN::DEBUG;
- return $self->success($self->{$slot})
- if $self->{$slot};
- }
-
- $self->debug("checking if tests passed[$self->{ID}]") if $CPAN::DEBUG;
- if ( $self->{make_test} ) {
- if (
- UNIVERSAL::can($self->{make_test},"failed") ?
- $self->{make_test}->failed :
- $self->{make_test} =~ /^NO/
- ) {
- if (
- UNIVERSAL::can($self->{make_test},"commandid")
- &&
- $self->{make_test}->commandid == $CPAN::CurrentCommandId
- ) {
- return $self->goodbye("Has already been tested within this command");
- }
- } else {
- # if global "is_tested" has been cleared, we need to mark this to
- # be added to PERL5LIB if not already installed
- if ($self->tested_ok_but_not_installed) {
- $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
- }
- return $self->success("Has already been tested successfully");
- }
- }
-
- if ($self->{notest}) {
- $self->{make_test} = CPAN::Distrostatus->new("YES");
- return $self->success("Skipping test because of notest pragma");
- }
-
- return undef; # no shortcut
-}
-
-#-> sub CPAN::Distribution::_exe_files ;
-sub _exe_files {
- my($self) = @_;
- return unless $self->{writemakefile} # no need to have succeeded
- # but we must have run it
- || $self->{modulebuild};
- unless ($self->{build_dir}) {
- return;
- }
- CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
- $self->{writemakefile}||"",
- $self->{modulebuild}||"",
- ) if $CPAN::DEBUG;
- my $build_dir;
- unless ( $build_dir = $self->{build_dir} ) {
- return;
- }
- my $makefile = File::Spec->catfile($build_dir,"Makefile");
- my $fh;
- my @exe_files;
- if (-f $makefile
- and
- $fh = FileHandle->new("<$makefile\0")) {
- CPAN->debug("Getting exefiles from Makefile") if $CPAN::DEBUG;
- local($/) = "\n";
- while (<$fh>) {
- last if /MakeMaker post_initialize section/;
- my($p) = m{^[\#]
- \s+EXE_FILES\s+=>\s+\[(.+)\]
- }x;
- next unless $p;
- # warn "Found exefiles expr[$p]";
- my @p = split /,\s*/, $p;
- for my $p2 (@p) {
- if ($p2 =~ /^q\[(.+)\]/) {
- push @exe_files, $1;
- }
- }
- }
- }
- return \@exe_files if @exe_files;
- my $buildparams = File::Spec->catfile($build_dir,"_build","build_params");
- if (-f $buildparams) {
- CPAN->debug("Found '$buildparams'") if $CPAN::DEBUG;
- my $x = do $buildparams;
- for my $sf (@{$x->[2]{script_files} || []}) {
- push @exe_files, $sf;
- }
+ if ($req || $breq) {
+ return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
}
- return \@exe_files;
}
#-> sub CPAN::Distribution::test ;
sub test {
my($self) = @_;
-
- $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
-
- $self->make
- or return;
-
- if ( defined( my $sc = $self->shortcut_test ) ) {
- return $sc;
- }
-
+ $self->make;
+ return if $self->prefs->{disabled} && ! $self->{force_update};
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
# warn "XDEBUG: checking for notest: $self->{notest} $self";
+ if ($self->{notest}) {
+ $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
+ return 1;
+ }
+
my $make = $self->{modulebuild} ? "Build" : "make";
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
@@ -3439,19 +2950,66 @@ sub test {
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
- local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
- local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
$CPAN::Frontend->myprint("Running $make test\n");
- my $builddir = $self->dir or
- $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
-
- unless (chdir $builddir) {
- $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
- return;
+ EXCUSE: {
+ my @e;
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
+ push @e,
+ "Make had some problems, won't test";
+ }
+
+ exists $self->{make} and
+ (
+ UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/
+ ) and push @e, "Can't test without successful make";
+ $self->{badtestcnt} ||= 0;
+ if ($self->{badtestcnt} > 0) {
+ require Data::Dumper;
+ CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
+ push @e, "Won't repeat unsuccessful test during this command";
+ }
+
+ push @e, $self->{later} if $self->{later};
+ push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
+
+ if (exists $self->{build_dir}) {
+ if (exists $self->{make_test}) {
+ if (
+ UNIVERSAL::can($self->{make_test},"failed") ?
+ $self->{make_test}->failed :
+ $self->{make_test} =~ /^NO/
+ ) {
+ if (
+ UNIVERSAL::can($self->{make_test},"commandid")
+ &&
+ $self->{make_test}->commandid == $CPAN::CurrentCommandId
+ ) {
+ push @e, "Has already been tested within this command";
+ }
+ } else {
+ push @e, "Has already been tested successfully";
+ # if global "is_tested" has been cleared, we need to mark this to
+ # be added to PERL5LIB if not already installed
+ if ($self->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
+ }
+ }
+ }
+ } elsif (!@e) {
+ push @e, "Has no own directory";
+ }
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ unless (chdir $self->{build_dir}) {
+ push @e, "Couldn't chdir to '$self->{build_dir}': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
-
$self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
@@ -3480,7 +3038,7 @@ sub test {
# bypass actual tests if "trust_test_report_history" and have a report
my $have_tested_fcn;
if ( $CPAN::Config->{trust_test_report_history}
- && $CPAN::META->has_inst("CPAN::Reporter::History")
+ && $CPAN::META->has_inst("CPAN::Reporter::History")
&& ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
# Do nothing if grade was DISCARD
@@ -3512,7 +3070,7 @@ sub test {
$ENV{PERL} = CPAN::find_perl();
} elsif ($self->{modulebuild}) {
$system = sprintf "%s test", $self->_build_command();
- unless (-e "Build" || ($^O eq 'VMS' && -e "Build.com")) {
+ unless (-e "Build") {
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
}
@@ -3525,11 +3083,21 @@ sub test {
$make_test_arg ? " $make_test_arg" : "",
);
my($tests_ok);
+ my %env;
+ while (my($k,$v) = each %ENV) {
+ next unless defined $v;
+ $env{$k} = $v;
+ }
+ local %ENV = %env;
my $test_env;
if ($self->prefs->{test}) {
$test_env = $self->prefs->{test}{env};
}
- local @ENV{keys %$test_env} = values %$test_env if $test_env;
+ if ($test_env) {
+ for my $e (keys %$test_env) {
+ $ENV{$e} = $test_env->{$e};
+ }
+ }
my $expect_model = $self->_prefs_with_expect("test");
my $want_expect = 0;
if ( $expect_model && @{$expect_model->{talk}} ) {
@@ -3554,14 +3122,50 @@ sub test {
$tests_ok = system($system) == 0;
}
$self->introduce_myself;
- my $but = $self->_make_test_illuminate_prereqs();
if ( $tests_ok ) {
- if ($but) {
- $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
- $self->{make_test} = CPAN::Distrostatus->new("NO $but");
- $self->store_persistent_state;
- return $self->goodbye("[dependencies] -- NA");
+ {
+ my @prereq;
+
+ # local $CPAN::DEBUG = 16; # Distribution
+ for my $m (keys %{$self->{sponsored_mods}}) {
+ next unless $self->{sponsored_mods}{$m} > 0;
+ my $m_obj = CPAN::Shell->expand("Module",$m) or next;
+ # XXX we need available_version which reflects
+ # $ENV{PERL5LIB} so that already tested but not yet
+ # installed modules are counted.
+ my $available_version = $m_obj->available_version;
+ my $available_file = $m_obj->available_file;
+ if ($available_version &&
+ !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
+ ) {
+ CPAN->debug("m[$m] good enough available_version[$available_version]")
+ if $CPAN::DEBUG;
+ } elsif ($available_file
+ && (
+ !$self->{prereq_pm}{$m}
+ ||
+ $self->{prereq_pm}{$m} == 0
+ )
+ ) {
+ # lex Class::Accessor::Chained::Fast which has no $VERSION
+ CPAN->debug("m[$m] have available_file[$available_file]")
+ if $CPAN::DEBUG;
+ } else {
+ push @prereq, $m;
+ }
+ }
+ if (@prereq) {
+ my $cnt = @prereq;
+ my $which = join ",", @prereq;
+ my $but = $cnt == 1 ? "one dependency not OK ($which)" :
+ "$cnt dependencies missing ($which)";
+ $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO $but");
+ $self->store_persistent_state;
+ return $self->goodbye("[dependencies] -- NA");
+ }
}
+
$CPAN::Frontend->myprint(" $system -- OK\n");
$self->{make_test} = CPAN::Distrostatus->new("YES");
$CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
@@ -3569,17 +3173,7 @@ sub test {
# has a lifespan of one command
delete $self->{badtestcnt};
} else {
- if ($but) {
- $but .= "; additionally test harness failed";
- $CPAN::Frontend->mywarn("$but\n");
- $self->{make_test} = CPAN::Distrostatus->new("NO $but");
- } elsif ( $self->{force_update} ) {
- $self->{make_test} = CPAN::Distrostatus->new(
- "NO but failure ignored because 'force' in effect"
- );
- } else {
- $self->{make_test} = CPAN::Distrostatus->new("NO");
- }
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
$self->{badtestcnt}++;
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
CPAN::Shell->optprint
@@ -3590,51 +3184,6 @@ sub test {
$self->pretty_id));
}
$self->store_persistent_state;
-
- return $self->{force_update} ? 1 : !! $tests_ok;
-}
-
-sub _make_test_illuminate_prereqs {
- my($self) = @_;
- my @prereq;
-
- # local $CPAN::DEBUG = 16; # Distribution
- for my $m (keys %{$self->{sponsored_mods}}) {
- next unless $self->{sponsored_mods}{$m} > 0;
- my $m_obj = CPAN::Shell->expand("Module",$m) or next;
- # XXX we need available_version which reflects
- # $ENV{PERL5LIB} so that already tested but not yet
- # installed modules are counted.
- my $available_version = $m_obj->available_version;
- my $available_file = $m_obj->available_file;
- if ($available_version &&
- !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
- ) {
- CPAN->debug("m[$m] good enough available_version[$available_version]")
- if $CPAN::DEBUG;
- } elsif ($available_file
- && (
- !$self->{prereq_pm}{$m}
- ||
- $self->{prereq_pm}{$m} == 0
- )
- ) {
- # lex Class::Accessor::Chained::Fast which has no $VERSION
- CPAN->debug("m[$m] have available_file[$available_file]")
- if $CPAN::DEBUG;
- } else {
- push @prereq, $m
- if $m_obj->{mandatory};
- }
- }
- my $but;
- if (@prereq) {
- my $cnt = @prereq;
- my $which = join ",", @prereq;
- $but = $cnt == 1 ? "one dependency not OK ($which)" :
- "$cnt dependencies missing ($which)";
- }
- $but;
}
sub _prefs_with_expect {
@@ -3736,20 +3285,6 @@ sub clean {
$self->store_persistent_state;
}
-#-> sub CPAN::Distribution::check_disabled ;
-sub check_disabled {
- my ($self) = @_;
- $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
- if ($self->prefs->{disabled} && ! $self->{force_update}) {
- return sprintf(
- "Disabled via prefs file '%s' doc %d",
- $self->{prefs_file},
- $self->{prefs_file_doc},
- );
- }
- return;
-}
-
#-> sub CPAN::Distribution::goto ;
sub goto {
my($self,$goto) = @_;
@@ -3776,76 +3311,85 @@ sub goto {
my($method) = (caller(1))[3];
CPAN->instance("CPAN::Distribution",$goto)->$method();
CPAN::Queue->delete_first($goto);
- # XXX delete_first returns undef; is that what this should return
- # up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
-}
-
-#-> sub CPAN::Distribution::shortcut_install ;
-# return values: undef means don't shortcut; 0 means shortcut as fail;
-# and 1 means shortcut as success
-sub shortcut_install {
- my ($self) = @_;
-
- $self->debug("checking previous install results[$self->{ID}]") if $CPAN::DEBUG;
- if (exists $self->{install}) {
- my $text = UNIVERSAL::can($self->{install},"text") ?
- $self->{install}->text :
- $self->{install};
- if ($text =~ /^YES/) {
- $CPAN::META->is_installed($self->{build_dir});
- return $self->success("Already done");
- } elsif ($text =~ /is only/) {
- # e.g. 'is only build_requires'
- return $self->goodbye($text);
- } else {
- # comment in Todo on 2006-02-11; maybe retry?
- return $self->goodbye("Already tried without success");
- }
- }
-
- for my $slot ( qw/later configure_requires_later/ ) {
- return $self->success($self->{$slot})
- if $self->{$slot};
- }
-
- return undef;
}
#-> sub CPAN::Distribution::install ;
sub install {
my($self) = @_;
-
- $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
-
- $self->test
- or return;
-
- if ( defined( my $sc = $self->shortcut_install ) ) {
- return $sc;
+ unless ($self->{badtestcnt}) {
+ $self->test;
}
-
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
+ my $make = $self->{modulebuild} ? "Build" : "make";
+ $CPAN::Frontend->myprint("Running $make install\n");
+ EXCUSE: {
+ my @e;
+ if ($self->{make} or $self->{later}) {
+ # go ahead
+ } else {
+ push @e,
+ "Make had some problems, won't install";
+ }
- my $builddir = $self->dir or
- $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
+ exists $self->{make} and
+ (
+ UNIVERSAL::can($self->{make},"failed") ?
+ $self->{make}->failed :
+ $self->{make} =~ /^NO/
+ ) and
+ push @e, "Make had returned bad status, install seems impossible";
- unless (chdir $builddir) {
- $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
- return;
- }
+ if (exists $self->{build_dir}) {
+ } elsif (!@e) {
+ push @e, "Has no own directory";
+ }
+ if (exists $self->{make_test} and
+ (
+ UNIVERSAL::can($self->{make_test},"failed") ?
+ $self->{make_test}->failed :
+ $self->{make_test} =~ /^NO/
+ )) {
+ if ($self->{force_update}) {
+ $self->{make_test}->text("FAILED but failure ignored because ".
+ "'force' in effect");
+ } else {
+ push @e, "make test had returned bad status, ".
+ "won't install without force"
+ }
+ }
+ if (exists $self->{install}) {
+ if (UNIVERSAL::can($self->{install},"text") ?
+ $self->{install}->text eq "YES" :
+ $self->{install} =~ /^YES/
+ ) {
+ $CPAN::Frontend->myprint(" Already done\n");
+ $CPAN::META->is_installed($self->{build_dir});
+ return 1;
+ } else {
+ # comment in Todo on 2006-02-11; maybe retry?
+ push @e, "Already tried without success";
+ }
+ }
+
+ push @e, $self->{later} if $self->{later};
+ push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
+
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ unless (chdir $self->{build_dir}) {
+ push @e, "Couldn't chdir to '$self->{build_dir}': $!";
+ }
+ $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
+ }
$self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
- my $make = $self->{modulebuild} ? "Build" : "make";
- $CPAN::Frontend->myprint("Running $make install\n");
-
if ($^O eq 'MacOS') {
Mac::BuildTools::make_install($self);
return;
@@ -3861,22 +3405,22 @@ sub install {
$CPAN::Config->{mbuild_install_build_command} ?
$CPAN::Config->{mbuild_install_build_command} :
$self->_build_command();
- my $install_directive = $^O eq 'VMS' ? '"install"' : 'install';
- $system = sprintf("%s %s %s",
+ $system = sprintf("%s install %s",
$mbuild_install_build_command,
- $install_directive,
$CPAN::Config->{mbuild_install_arg},
);
-
} else {
- my($make_install_make_command) = $self->_make_install_make_command();
+ my($make_install_make_command) =
+ CPAN::HandleConfig->prefs_lookup($self,
+ q{make_install_make_command})
+ || $self->_make_command();
$system = sprintf("%s install %s",
$make_install_make_command,
$CPAN::Config->{make_install_arg},
);
}
- my($stderr) = $^O eq "MSWin32" || $^O eq 'VMS' ? "" : " 2>&1 ";
+ my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
my $brip = CPAN::HandleConfig->prefs_lookup($self,
q{build_requires_install_policy});
$brip ||="ask/yes";
@@ -3898,9 +3442,10 @@ sub install {
}
unless ($want_install =~ /^y/i) {
my $is_only = "is only 'build_requires'";
+ $CPAN::Frontend->mywarn("Not installing because $is_only\n");
$self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
delete $self->{force_update};
- return $self->goodbye("Not installing because $is_only");
+ return;
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
@@ -3908,9 +3453,6 @@ sub install {
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
- local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
- local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
-
my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
("Can't execute $system: $!");
my($makeout) = "";
@@ -3954,7 +3496,6 @@ sub install {
}
delete $self->{force_update};
$self->store_persistent_state;
- return !! $close_ok;
}
sub introduce_myself {
@@ -3985,7 +3526,7 @@ sub perldoc {
$CPAN::Frontend->myprint(qq{
Function system("@args")
returned status $estatus (wstat $wstatus)
- });
+ });
}
}
else {
@@ -4193,9 +3734,6 @@ sub _build_command {
my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
return "$perl ./Build";
}
- elsif ($^O eq 'VMS') {
- return "$^X Build.com";
- }
return "./Build";
}
@@ -4307,7 +3845,7 @@ sub reports {
}
$CPAN::Frontend->myprint("DONE\n\n");
my $yaml = $resp->content;
- # what a long way round!
+ # was fuer ein Umweg!
my $fh = File::Temp->new(
dir => File::Spec->tmpdir,
template => 'cpan_reports_XXXX',
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distroprefs.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distroprefs.pm
index 05b19faa47a..e1be9cdf749 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distroprefs.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distroprefs.pm
@@ -1,12 +1,11 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
-use 5.006;
use strict;
package CPAN::Distroprefs;
use vars qw($VERSION);
-$VERSION = '6.0001';
+$VERSION = '6';
package CPAN::Distroprefs::Result;
@@ -148,56 +147,29 @@ sub _load_st {
return @data;
}
-sub _build_file_list {
- if (@_ > 3) {
- die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
- }
- my ($dir, $dir1, $ext_re) = @_;
- my @list;
- my $dh;
- unless (opendir($dh, $dir)) {
- $CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
- return @list;
- }
- while (my $fn = readdir $dh) {
- next if $fn eq '.' || $fn eq '..';
- if (-d "$dir/$fn") {
- next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
- push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
- } else {
- if ($fn =~ $ext_re) {
- push @list, "$dir1$fn";
- }
- }
- }
- return @list;
-}
-
sub find {
my ($self, $dir, $ext_map) = @_;
- return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;
-
- my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
- my $ext_re = qr/\.($possible_ext)$/;
-
- my @files = _build_file_list($dir, '', $ext_re);
- @files = sort @files if @files;
+ my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!");
+ my @files = sort $dh->read;
# label the block so that we can use redo in the middle
return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
+ return unless %$ext_map;
- my $fn = shift @files;
- return unless defined $fn;
- my ($ext) = $fn =~ $ext_re;
+ local $_ = shift @files;
+ return unless defined;
+ redo if $_ eq '.' || $_ eq '..';
+ my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
+ my ($ext) = /\.($possible_ext)$/ or redo;
my $loader = $ext_map->{$ext};
my $result = CPAN::Distroprefs::Result->new({
- file => $fn, ext => $ext, dir => $dir
+ file => $_, ext => $ext, dir => $dir
});
# copied from CPAN.pm; is this ever actually possible?
- redo unless -f $result->abs;
+ redo unless -f $result->abs;
my $load_method = $self->_load_method($loader, $result);
my @prefs = eval { $self->$load_method($loader, $result) };
@@ -342,7 +314,7 @@ __END__
CPAN::Distroprefs -- read and match distroprefs
-=head1 SYNOPSIS
+=head1 SYNOPSIS
use CPAN::Distroprefs;
@@ -374,9 +346,7 @@ This module encapsulates reading L<Distroprefs|CPAN> and matching them against C
while (my $result = $finder->next) { ... }
-Build an iterator which finds distroprefs files in the tree below the
-given directory. Within the tree directories matching C<m/^[._]/> are
-pruned.
+Build an iterator which finds distroprefs files in the given directory.
C<%ext_map> is a hashref whose keys are file extensions and whose values are
modules used to load matching files:
@@ -411,7 +381,7 @@ All results share some common attributes:
C<success>, C<warning>, or C<fatal>
-=head3 file
+=head3 file
the file from which these prefs were read, or to which this error refers (relative filename)
@@ -443,7 +413,7 @@ Success results contain:
an arrayref of CPAN::Distroprefs::Pref objects
-=head1 PREFS
+=head1 PREFS
CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C<success> results from C<find()>.
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/blocked_urllist.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/blocked_urllist.pm
index 87d07d13f14..102c194e612 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/blocked_urllist.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/blocked_urllist.pm
@@ -7,7 +7,7 @@ use overload '""' => "as_string";
use vars qw(
$VERSION
);
-$VERSION = "1.001";
+$VERSION = "1.0";
sub new {
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm
index 1e7fa83a53b..e1259e5397d 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Exception/yaml_not_installed.pm
@@ -20,4 +20,54 @@ sub as_string {
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}
+package CPAN::Exception::yaml_process_error;
+use strict;
+use overload '""' => "as_string";
+
+use vars qw(
+ $VERSION
+);
+$VERSION = "5.5";
+
+
+sub new {
+ my($class,$module,$file,$during,$error) = @_;
+ # my $at = Carp::longmess(""); # XXX find something more beautiful
+ bless { module => $module,
+ file => $file,
+ during => $during,
+ error => $error,
+ # at => $at,
+ }, $class;
+}
+
+sub as_string {
+ my($self) = shift;
+ if ($self->{during}) {
+ if ($self->{file}) {
+ if ($self->{module}) {
+ if ($self->{error}) {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' the following error was encountered:\n".
+ " $self->{error}\n";
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "with '$self->{module}' some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' YAML file\n".
+ " '$self->{file}'\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: While trying to '$self->{during}' some YAML file\n".
+ "some unknown error was encountered\n";
+ }
+ } else {
+ return "Alert: unknown error encountered\n";
+ }
+}
+
1;
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm
index 831f234d3ce..268ca284678 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm
@@ -14,18 +14,13 @@ use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);
use vars qw(
$VERSION
);
-$VERSION = "5.5006";
+$VERSION = "5.5004";
#-> sub CPAN::FTP::ftp_statistics
# if they want to rewrite, they need to pass in a filehandle
sub _ftp_statistics {
my($self,$fh) = @_;
my $locktype = $fh ? LOCK_EX : LOCK_SH;
- # XXX On Windows flock() implements mandatory locking, so we can
- # XXX only use shared locking to still allow _yaml_load_file() to
- # XXX read from the file using a different filehandle.
- $locktype = LOCK_SH if $^O eq "MSWin32";
-
$fh ||= FileHandle->new;
my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
mkpath dirname $file;
@@ -48,21 +43,15 @@ sub _ftp_statistics {
if ($@) {
if (ref $@) {
if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
- chomp $@;
- $CPAN::Frontend->myprintonce("Warning (usually harmless): $@\n");
+ $CPAN::Frontend->myprint("Warning (usually harmless): $@\n");
return;
} elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
- my $time = time;
- my $to = "$file.$time";
- $CPAN::Frontend->myprint("Error reading '$file': $@\nStashing away as '$to' to prevent further interruptions. You may want to remove that file later.\n");
- rename $file, $to or $CPAN::Frontend->mydie("Could not rename: $!");
- return;
+ $CPAN::Frontend->mydie($@);
}
} else {
$CPAN::Frontend->mydie($@);
}
}
- CPAN::_flock($fh, LOCK_UN);
return $stats->[0];
}
@@ -574,7 +563,7 @@ sub hostdleasy { #called from hostdlxxx
$ThesiteURL = $ro_url;
return $l;
}
- # If request is for a compressed file and we can find the
+ # If request is for a compressed file and we can find the
# uncompressed file also, return the path of the uncompressed file
# otherwise, decompress it and return the resulting path
if ($l =~ /(.+)\.gz$/) {
@@ -583,16 +572,13 @@ sub hostdleasy { #called from hostdlxxx
$ThesiteURL = $ro_url;
return $ungz;
}
- elsif (-f $l && -r _) {
+ else {
eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
- if ( -f $aslocal && -s _) {
+ if ( -f $aslocal) {
$ThesiteURL = $ro_url;
return $aslocal;
}
- elsif (! -s $aslocal) {
- unlink $aslocal;
- }
- elsif (-f $l) {
+ else {
$CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
if $@;
return;
@@ -659,46 +645,8 @@ sub hostdleasy { #called from hostdlxxx
# Net::FTP can still succeed where LWP fails. So we do not
# skip Net::FTP anymore when LWP is available.
}
- } elsif ($url =~ /^http:/ && $CPAN::META->has_usable('HTTP::Tiny')) {
- require CPAN::HTTP::Client;
- my $chc = CPAN::HTTP::Client->new(
- proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy},
- no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy},
- );
- for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) {
- $CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n");
- my $res = eval { $chc->mirror($try, $aslocal) };
- if ( $res && $res->{success} ) {
- $ThesiteURL = $ro_url;
- my $now = time;
- utime $now, $now, $aslocal; # download time is more
- # important than upload
- # time
- return $aslocal;
- }
- elsif ( $res && $res->{status} ne '599') {
- $CPAN::Frontend->myprint(sprintf(
- "HTTP::Tiny failed with code[%s] message[%s]\n",
- $res->{status},
- $res->{reason},
- )
- );
- }
- elsif ( $res && $res->{status} eq '599') {
- $CPAN::Frontend->myprint(sprintf(
- "HTTP::Tiny failed with an internal error: %s\n",
- $res->{content},
- )
- );
- }
- else {
- my $err = $@ || 'Unknown error';
- $CPAN::Frontend->myprint(sprintf(
- "Error downloading with HTTP::Tiny: %s\n", $err
- )
- );
- }
- }
+ } else {
+ $CPAN::Frontend->mywarn(" LWP not available\n");
}
return if $CPAN::Signal;
if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
@@ -897,7 +845,7 @@ sub _proxy_vars {
}
if ($want_proxy) {
my($user, $pass) =
- CPAN::HTTP::Credentials->get_proxy_credentials();
+ &CPAN::LWP::UserAgent::get_proxy_credentials();
$ret = {
proxy_user => $user,
proxy_pass => $pass,
@@ -982,7 +930,7 @@ ftp config variable with
Trying with external ftp to get
'$url'
$netrc_explain
- Sending the dialog
+ Going to send the dialog
$dialog
}
);
@@ -1021,7 +969,7 @@ $dialog
$CPAN::Frontend->myprint(qq{
Trying with external ftp to get
$url
- Sending the dialog
+ Going to send the dialog
$dialog
}
);
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP/netrc.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP/netrc.pm
index 0778e8adbcc..c05405e7ef6 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP/netrc.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP/netrc.pm
@@ -1,12 +1,13 @@
package CPAN::FTP::netrc;
use strict;
-$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.01";
+$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.00";
# package CPAN::FTP::netrc;
sub new {
my($class) = @_;
- my $file = File::Spec->catfile($ENV{HOME},".netrc");
+ my $home = CPAN::HandleConfig::home();
+ my $file = File::Spec->catfile($home,".netrc");
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm
index d1a8eef2607..53ffbf1ef04 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm
@@ -1,5 +1,4 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
package CPAN::FirstTime;
use strict;
@@ -9,8 +8,8 @@ use File::Basename ();
use File::Path ();
use File::Spec ();
use CPAN::Mirrors ();
-use vars qw($VERSION $auto_config);
-$VERSION = "5.5306";
+use vars qw($VERSION $silent);
+$VERSION = "5.5301";
=head1 NAME
@@ -64,7 +63,7 @@ directory between sessions. Since 1.88_58 CPAN.pm has a YAML-based
mechanism that makes it possible to share the contents of the
build_dir/ directory between different sessions with the same version
of perl. People who prefer to test things several days before
-installing will like this feature because it saves a lot of time.
+installing will like this feature because it safes a lot of time.
If you say yes to the following question, CPAN will try to store
enough information about the build process so that it can pick up in
@@ -132,9 +131,6 @@ warnings, debugging output, and the output of the modules being
installed. Set your favorite colors after some experimenting with the
Term::ANSIColor module.
-Please note that on Windows platforms colorized output also requires
-the Win32::Console::ANSI module.
-
Do you want to turn on colored output?
=item colorize_print
@@ -204,10 +200,9 @@ Preferred method for determining the current working directory?
=item halt_on_failure
-Normally, CPAN.pm continues processing the full list of targets and
-dependencies, even if one of them fails. However, you can specify
-that CPAN should halt after the first failure. (Note that optional
-recommended or suggested modules that fail will not cause a halt.)
+Normaly, CPAN.pm continues processing the full list of targets and
+dependencies, even if one of them fails. However, you can specify
+that CPAN should halt after the first failure.
Do you want to halt on failure (yes/no)?
@@ -217,7 +212,7 @@ If you have one of the readline packages (Term::ReadLine::Perl,
Term::ReadLine::Gnu, possibly others) installed, the interactive CPAN
shell will have history support. The next two questions deal with the
filename of the history file and with its size. If you do not want to
-set this variable, please hit SPACE ENTER to the following question.
+set this variable, please hit SPACE RETURN to the following question.
File to save your history?
@@ -301,7 +296,6 @@ Parameters for the 'make install' command?
Typical frequently used setting:
UNINST=1 # to always uninstall potentially conflicting files
- # (but do NOT use with local::lib or INSTALL_BASE)
Your choice:
@@ -343,8 +337,7 @@ Your choice:
Parameters for the './Build install' command? Typical frequently used
setting:
- --uninst 1 # uninstall conflicting files
- # (but do NOT use with local::lib or INSTALL_BASE)
+ --uninst 1 # uninstall conflicting files
Your choice:
@@ -393,7 +386,7 @@ default options for CPAN.pm and the environment can be overridden and
dialog sequences can be stored that can later be executed by an
Expect.pm object. The CPAN.pm distribution comes with some prefab YAML
files that cover sample distributions that can be used as blueprints
-to store your own prefs. Please check out the distroprefs/ directory of
+to store one own prefs. Please check out the distroprefs/ directory of
the CPAN.pm distribution to get a quick start into the prefs system.
Directory where to store default options/environment/dialogs for
@@ -424,22 +417,13 @@ host should be tried first.
Randomize parameter
-=item recommends_policy
-
-(Experimental feature!) Some CPAN modules recommend additional, optional dependencies. These should
-generally be installed except in resource constrained environments. When this
-policy is true, recommended modules will be included with required modules.
-
-Included recommended modules?
-
=item scan_cache
By default, each time the CPAN module is started, cache scanning is
-performed to keep the cache size in sync ('atstart'). Alternatively,
-scanning and cleanup can happen when CPAN exits ('atexit'). To prevent
-any cache cleanup, answer 'never'.
+performed to keep the cache size in sync. To prevent this, answer
+'never'.
-Perform cache scanning ('atstart', 'atexit' or 'never')?
+Perform cache scanning (atstart or never)?
=item shell
@@ -474,14 +458,6 @@ variable.
Show all individual modules that have a $VERSION of zero?
-=item suggests_policy
-
-(Experimental feature!) Some CPAN modules suggest additional, optional dependencies. These 'suggest'
-dependencies provide enhanced operation. When this policy is true, suggested
-modules will be included with required modules.
-
-Included suggested modules?
-
=item tar_verbosity
When CPAN.pm uses the tar command, which switch for the verbosity
@@ -492,7 +468,7 @@ Tar command verbosity level (none or v or vv)?
=item term_is_latin
-The next option deals with the charset (a.k.a. character set) your
+The next option deals with the charset (aka character set) your
terminal supports. In general, CPAN is English speaking territory, so
the charset does not matter much but some CPAN have names that are
outside the ASCII range. If your terminal supports UTF-8, you should
@@ -520,14 +496,14 @@ improves the overall quality and value of CPAN.
One way you can contribute is to send test results for each module
that you install. If you install the CPAN::Reporter module, you have
-the option to automatically generate and deliver test reports to CPAN
+the option to automatically generate and email test reports to CPAN
Testers whenever you run tests on a CPAN package.
See the CPAN::Reporter documentation for additional details and
-configuration settings. If your firewall blocks outgoing traffic,
-you may need to configure CPAN::Reporter before sending reports.
+configuration settings. If your firewall blocks outgoing email,
+you will need to configure CPAN::Reporter before sending reports.
-Generate test reports if CPAN::Reporter is installed (yes/no)?
+Email test reports if CPAN::Reporter is installed (yes/no)?
=item perl5lib_verbosity
@@ -537,15 +513,6 @@ added). Choose 'v' to get this message, 'none' to suppress it.
Verbosity level for PERL5LIB changes (none or v)?
-=item prefer_external_tar
-
-Per default all untar operations are done with the perl module
-Archive::Tar; by setting this variable to true the external tar
-command is used if available; on Unix this is usually preferred
-because they have a reliable and fast gnutar implementation.
-
-Use the external tar program instead of Archive::Tar?
-
=item trust_test_report_history
When a distribution has already been tested by CPAN::Reporter on
@@ -558,17 +525,6 @@ regardless of the history using "force".
Do you want to rely on the test report history (yes/no)?
-=item use_prompt_default
-
-When this is true, CPAN will set PERL_MM_USE_DEFAULT to a true
-value. This causes ExtUtils::MakeMaker (and compatible) prompts
-to use default values instead of stopping to prompt you to answer
-questions. It also sets NONINTERACTIVE_TESTING to a true value to
-signal more generally that distributions should not try to
-interact with you.
-
-Do you want to use prompt defaults (yes/no)?
-
=item use_sqlite
CPAN::SQLite is a layer between the index files that are downloaded
@@ -622,16 +578,26 @@ use vars qw( %prompts );
my @prompts = (
-auto_config => qq{
-CPAN.pm requires configuration, but most of it can be done automatically.
-If you answer 'no' below, you will enter an interactive dialog for each
-configuration option instead.
+manual_config => qq[
+CPAN is the world-wide archive of perl resources. It consists of about
+300 sites that all replicate the same contents around the globe. Many
+countries have at least one CPAN site already. The resources found on
+CPAN are easily accessible with the CPAN.pm module. If you want to use
+CPAN.pm, lots of things have to be configured. Fortunately, most of
+them can be determined automatically. If you prefer the automatic
+configuration, answer 'yes' below.
+
+If you prefer to enter a dialog instead, you can answer 'no' to this
+question and I'll let you configure in small steps one thing after the
+other. (Note: you can revisit this dialog anytime later by typing 'o
+conf init' at the cpan prompt.)
-Would you like to configure as much as possible automatically?},
+],
auto_pick => qq{
-Would you like me to automatically choose some CPAN mirror
-sites for you? (This means connecting to the Internet)},
+Would you like me to automatically choose the best CPAN mirror
+sites for you? (This means connecting to the Internet and could
+take a couple minutes)},
config_intro => qq{
@@ -670,7 +636,7 @@ the \$CPAN::Config takes precedence.
proxy_user => qq{
If your proxy is an authenticating proxy, you can store your username
-permanently. If you do not want that, just press ENTER. You will then
+permanently. If you do not want that, just press RETURN. You will then
be asked for your username in every future session.
},
@@ -679,7 +645,7 @@ proxy_pass => qq{
Your password for the authenticating proxy can also be stored
permanently on disk. If this violates your security policy, just press
-ENTER. You will then be asked for the password in every future
+RETURN. You will then be asked for the password in every future
session.
},
@@ -709,24 +675,6 @@ be echoed to the terminal!
},
-install_help => qq{
-Warning: You do not have write permission for Perl library directories.
-
-To install modules, you need to configure a local Perl library directory or
-escalate your privileges. CPAN can help you by bootstrapping the local::lib
-module or by configuring itself to use 'sudo' (if available). You may also
-resolve this problem manually if you need to customize your setup.
-
-What approach do you want? (Choose 'local::lib', 'sudo' or 'manual')
-},
-
-local_lib_installed => qq{
-local::lib is installed. You must now add the following environment variables
-to your shell configuration files (or registry, if you are on Windows) and
-then restart your command line shell and CPAN before installing modules:
-
-},
-
);
die "Coding error in \@prompts declaration. Odd number of elements, above"
@@ -808,17 +756,33 @@ sub init {
#= Files, directories
#
+ unless ($matcher) {
+ $CPAN::Frontend->myprint($prompts{manual_config});
+ }
+
+ my $manual_conf;
+
local *_real_prompt;
if ( $args{autoconfig} ) {
- $auto_config = 1;
+ $manual_conf = "no";
} elsif ($matcher) {
- $auto_config = 0;
+ $manual_conf = "yes";
} else {
- my $_conf = prompt($prompts{auto_config}, "yes");
- $auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0;
+ my $_conf = prompt("Would you like me to configure as much as possible ".
+ "automatically?", "yes");
+ $manual_conf = ($_conf and $_conf =~ /^y/i) ? "no" : "yes";
}
- CPAN->debug("auto_config[$auto_config]") if $CPAN::DEBUG;
- if ( $auto_config ) {
+ CPAN->debug("manual_conf[$manual_conf]") if $CPAN::DEBUG;
+ my $fastread;
+ {
+ if ($manual_conf =~ /^y/i) {
+ $fastread = 0;
+ } else {
+ $fastread = 1;
+ $silent = 1;
+ $CPAN::Config->{urllist} ||= [];
+ $CPAN::Config->{connect_to_internet_ok} ||= 1;
+
local $^W = 0;
# prototype should match that of &MakeMaker::prompt
my $current_second = time;
@@ -826,21 +790,9 @@ sub init {
my $i_am_mad = 0;
# silent prompting -- just quietly use default
*_real_prompt = sub { return $_[1] };
+ }
}
- #
- # bootstrap local::lib or sudo
- #
- unless ( $matcher
- || _can_write_to_libdirs() || _using_installbase() || _using_sudo()
- ) {
- local $auto_config = 0; # We *must* ask, even under autoconfig
- local *_real_prompt; # We *must* show prompt
- my_prompt_loop(install_help => 'local::lib', $matcher,
- 'local::lib|sudo|manual');
- }
- $CPAN::Config->{install_help} ||= ''; # Temporary to suppress warnings
-
if (!$matcher or q{
build_dir
build_dir_reuse
@@ -848,7 +800,7 @@ sub init {
keep_source_where
prefs_dir
} =~ /$matcher/) {
- $CPAN::Frontend->myprint($prompts{config_intro}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{config_intro}) unless $silent;
init_cpan_home($matcher);
@@ -879,7 +831,7 @@ sub init {
my_dflt_prompt(build_cache => 100, $matcher);
my_dflt_prompt(index_expire => 1, $matcher);
- my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|atexit|never');
+ my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|never');
#
#= cache_metadata
@@ -896,8 +848,6 @@ sub init {
'follow|ask|ignore');
my_prompt_loop(build_requires_install_policy => 'yes', $matcher,
'yes|no|ask/yes|ask/no');
- my_yn_prompt(recommends_policy => 1, $matcher);
- my_yn_prompt(suggests_policy => 0, $matcher);
#
#= Module::Signature
@@ -910,12 +860,13 @@ sub init {
if (!$matcher or 'test_report' =~ /$matcher/) {
my_yn_prompt(test_report => 0, $matcher);
if (
- $matcher &&
$CPAN::Config->{test_report} &&
$CPAN::META->has_inst("CPAN::Reporter") &&
CPAN::Reporter->can('configure')
) {
- my $_conf = prompt("Would you like me configure CPAN::Reporter now?", "yes");
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ my $_conf = prompt("Would you like me configure CPAN::Reporter now?", $silent ? "no" : "yes");
if ($_conf =~ /^y/i) {
$CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n");
CPAN::Reporter::configure();
@@ -933,7 +884,7 @@ sub init {
my_dflt_prompt(yaml_module => "YAML", $matcher);
my $old_v = $CPAN::Config->{load_module_verbosity};
$CPAN::Config->{load_module_verbosity} = q[none];
- if (!$auto_config && !$CPAN::META->has_inst($CPAN::Config->{yaml_module})) {
+ if (!$silent && !$CPAN::META->has_inst($CPAN::Config->{yaml_module})) {
$CPAN::Frontend->mywarn
("Warning (maybe harmless): '$CPAN::Config->{yaml_module}' not installed.\n");
$CPAN::Frontend->mysleep(3);
@@ -950,18 +901,7 @@ sub init {
#= External programs
#
my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
- $CPAN::Frontend->myprint($prompts{external_progs})
- if !$matcher && !$auto_config;
- _init_external_progs($matcher, {
- path => \@path,
- progs => [ qw/make bzip2 gzip tar unzip gpg patch applypatch/ ],
- shortcut => 0
- });
- _init_external_progs($matcher, {
- path => \@path,
- progs => [ qw/wget curl lynx ncftpget ncftp ftp/ ],
- shortcut => 1
- });
+ _init_external_progs($matcher,\@path);
{
my $path = $CPAN::Config->{'pager'} ||
@@ -988,22 +928,6 @@ sub init {
}
}
- {
- my $tar = $CPAN::Config->{tar};
- my $prefer_external_tar = $CPAN::Config->{prefer_external_tar}; # XXX not yet supported
- unless (defined $prefer_external_tar) {
- if ($^O =~ /(MSWin32|solaris)/) {
- # both have a record of broken tars
- $prefer_external_tar = 0;
- } elsif ($tar) {
- $prefer_external_tar = 1;
- } else {
- $prefer_external_tar = 0;
- }
- }
- my_yn_prompt(prefer_external_tar => $prefer_external_tar, $matcher);
- }
-
#
# verbosity
#
@@ -1026,8 +950,8 @@ sub init {
my_dflt_prompt(makepl_arg => "", $matcher);
my_dflt_prompt(make_arg => "", $matcher);
if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) {
- $CPAN::Frontend->mywarn(
- "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
+ $CPAN::Frontend->mywarn(
+ "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
"that specify their own LIBS or INC options in Makefile.PL.\n"
);
}
@@ -1038,18 +962,8 @@ sub init {
if (exists $CPAN::HandleConfig::keys{make_install_make_command}) {
# as long as Windows needs $self->_build_command, we cannot
# support sudo on windows :-)
- my $default = $CPAN::Config->{make} || "";
- if ( $default && $CPAN::Config->{install_help} eq 'sudo' ) {
- if ( find_exe('sudo') ) {
- $default = "sudo $default";
- delete $CPAN::Config->{make_install_make_command}
- unless $CPAN::Config->{make_install_make_command} =~ /sudo/;
- }
- else {
- $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n");
- }
- }
- my_dflt_prompt(make_install_make_command => $default, $matcher);
+ my_dflt_prompt(make_install_make_command => $CPAN::Config->{make} || "",
+ $matcher);
}
my_dflt_prompt(make_install_arg => $CPAN::Config->{make_arg} || "",
@@ -1062,28 +976,12 @@ sub init {
and $^O ne "MSWin32") {
# as long as Windows needs $self->_build_command, we cannot
# support sudo on windows :-)
- my $default = $^O eq 'VMS' ? '@Build.com' : "./Build";
- if ( $CPAN::Config->{install_help} eq 'sudo' ) {
- if ( find_exe('sudo') ) {
- $default = "sudo $default";
- delete $CPAN::Config->{mbuild_install_build_command}
- unless $CPAN::Config->{mbuild_install_build_command} =~ /sudo/;
- }
- else {
- $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n");
- }
- }
- my_dflt_prompt(mbuild_install_build_command => $default, $matcher);
+ my_dflt_prompt(mbuild_install_build_command => "./Build", $matcher);
}
my_dflt_prompt(mbuild_install_arg => "", $matcher);
#
- #== use_prompt_default
- #
- my_yn_prompt(use_prompt_default => 0, $matcher);
-
- #
#= Alarm period
#
@@ -1102,7 +1000,7 @@ sub init {
my @proxy_vars = qw/ftp_proxy http_proxy no_proxy/;
my @proxy_user_vars = qw/proxy_user proxy_pass/;
if (!$matcher or "@proxy_vars @proxy_user_vars" =~ /$matcher/) {
- $CPAN::Frontend->myprint($prompts{proxy_intro}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{proxy_intro}) unless $silent;
for (@proxy_vars) {
$prompts{$_} = "Your $_?";
@@ -1114,21 +1012,21 @@ sub init {
$default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER || "";
- $CPAN::Frontend->myprint($prompts{proxy_user}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{proxy_user}) unless $silent;
if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
- $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $silent;
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("noecho");
} else {
- $CPAN::Frontend->myprint($prompts{password_warn}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{password_warn}) unless $silent;
}
$CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?");
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("restore");
}
- $CPAN::Frontend->myprint("\n\n") unless $auto_config;
+ $CPAN::Frontend->myprint("\n\n") unless $silent;
}
}
}
@@ -1158,24 +1056,24 @@ sub init {
if ($CPAN::META->has_inst("Term::ANSIColor")) {
my $T="gYw";
$CPAN::Frontend->myprint( " on_ on_y ".
- " on_ma on_\n") unless $auto_config;
+ " on_ma on_\n") unless $silent;
$CPAN::Frontend->myprint( " on_black on_red green ellow ".
- "on_blue genta on_cyan white\n") unless $auto_config;
+ "on_blue genta on_cyan white\n") unless $silent;
for my $FG ("", "bold",
map {$_,"bold $_"} "black","red","green",
"yellow","blue",
"magenta",
"cyan","white") {
- $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $auto_config;
+ $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $silent;
for my $BG ("",map {"on_$_"} qw(black red green yellow
blue magenta cyan white)) {
$CPAN::Frontend->myprint( $FG||$BG ?
- Term::ANSIColor::colored(" $T ","$FG $BG") : " $T ") unless $auto_config;
+ Term::ANSIColor::colored(" $T ","$FG $BG") : " $T ") unless $silent;
}
- $CPAN::Frontend->myprint( "\n" ) unless $auto_config;
+ $CPAN::Frontend->myprint( "\n" ) unless $silent;
}
- $CPAN::Frontend->myprint( "\n" ) unless $auto_config;
+ $CPAN::Frontend->myprint( "\n" ) unless $silent;
}
for my $tuple (
["colorize_print", "bold blue on_white"],
@@ -1205,7 +1103,7 @@ sub init {
#
if (!$matcher or 'histfile histsize' =~ /$matcher/) {
- $CPAN::Frontend->myprint($prompts{histfile_intro}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{histfile_intro}) unless $silent;
defined($default = $CPAN::Config->{histfile}) or
$default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile");
my_dflt_prompt(histfile => $default, $matcher);
@@ -1228,6 +1126,7 @@ sub init {
or 'show_unparsable_versions' =~ /$matcher/
or 'show_zero_versions' =~ /$matcher/
) {
+ $CPAN::Frontend->myprint($prompts{show_unparsable_or_zero_versions_intro});
my_yn_prompt(show_unparsable_versions => 0, $matcher);
my_yn_prompt(show_zero_versions => 0, $matcher);
}
@@ -1236,12 +1135,35 @@ sub init {
#= MIRRORED.BY and conf_sites()
#
- # Let's assume they want to use the internet and make them turn it
- # off if they really don't.
- my_yn_prompt("connect_to_internet_ok" => 1, $matcher);
-
- # Allow matching but don't show during manual config
+ # remember, this is only triggered if no urllist is given, so 0 is
+ # fair and protects the default site from being overloaded and
+ # gives the user more chances to select his own urllist.
+ my_yn_prompt("connect_to_internet_ok" => $fastread ? 1 : 0, $matcher);
+ $CPAN::Config->{urllist} ||= [];
if ($matcher) {
+ if ("urllist" =~ $matcher) {
+ $CPAN::Frontend->myprint($prompts{urls_intro});
+
+ # conf_sites would go into endless loop with the smash prompt
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ my $_conf = prompt($prompts{auto_pick}, "yes");
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites( auto_pick => 1 ) or bring_your_own();
+ }
+ else {
+ my $_conf = prompt(
+ "Would you like to pick from the CPAN mirror list?", "yes"
+ );
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites();
+ }
+ bring_your_own();
+ }
+ _print_urllist();
+ }
if ("randomize_urllist" =~ $matcher) {
my_dflt_prompt(randomize_urllist => 0, $matcher);
}
@@ -1251,214 +1173,70 @@ sub init {
if ("ftpstats_period" =~ $matcher) {
my_dflt_prompt(ftpstats_period => 14, $matcher);
}
- }
-
- $CPAN::Config->{urllist} ||= [];
-
- if ($auto_config) {
- if(@{ $CPAN::Config->{urllist} }) {
+ } elsif ($fastread) {
+ $silent = 0;
+ local *_real_prompt;
+ *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
+ if ( @{ $CPAN::Config->{urllist} } ) {
$CPAN::Frontend->myprint(
- "Your 'urllist' is already configured. Type 'o conf init urllist' to change it.\n"
+ "\nYour 'urllist' is already configured. Type 'o conf init urllist' to change it.\n"
);
}
else {
- $CPAN::Config->{urllist} = [ 'http://www.cpan.org/' ];
- }
- }
- elsif (!$matcher || "urllist" =~ $matcher) {
- _do_pick_mirrors();
- }
+ $CPAN::Frontend->myprint(
+ "Autoconfigured everything but 'urllist'.\n"
+ );
- if ($auto_config) {
- $CPAN::Frontend->myprint(
- "\nAutoconfiguration complete.\n"
- );
- $auto_config = 0; # reset
- }
+ $CPAN::Frontend->myprint($prompts{urls_intro});
- # bootstrap local::lib now if requested
- if ( $CPAN::Config->{install_help} eq 'local::lib' ) {
- if ( ! @{ $CPAN::Config->{urllist} } ) {
- $CPAN::Frontend->myprint(
- "Skipping local::lib bootstrap because 'urllist' is not configured.\n"
+ my $_conf = prompt($prompts{auto_pick}, "yes");
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites( auto_pick => 1 ) or bring_your_own();
+ }
+ else {
+ my $_conf = prompt(
+ "Would you like to pick from the CPAN mirror list?", "yes"
);
- }
- else {
- $CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n");
- $CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n");
- delete $CPAN::Config->{install_help}; # temporary only
- CPAN::HandleConfig->commit;
- my $dist;
- if ( $dist = CPAN::Shell->expand('Module', 'local::lib')->distribution ) {
- # this is a hack to force bootstrapping
- $dist->{prefs}{pl}{commandline} = "$^X Makefile.PL --bootstrap";
- # Set @INC for this process so we find things as they bootstrap
- require lib;
- lib->import(_local_lib_inc_path());
- eval { $dist->install };
- }
- if ( ! $dist || (my $err = $@) ) {
- $err ||= 'Could not locate local::lib in the CPAN index';
- $CPAN::Frontend->mywarn("Error bootstrapping local::lib: $@\n");
- $CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n"
- . "run 'perl Makefile --bootstrap' and see if that is successful. Then\n"
- . "restart your CPAN client\n"
- );
- }
- else {
- _local_lib_config();
+
+ if ( $_conf =~ /^y/i ) {
+ conf_sites();
}
+ bring_your_own();
+ }
+ _print_urllist();
}
+ $CPAN::Frontend->myprint(
+ "\nAutoconfiguration complete.\n"
+ );
}
- # install_help is temporary for configuration and not saved
- delete $CPAN::Config->{install_help};
+ $silent = 0; # reset
$CPAN::Frontend->myprint("\n");
if ($matcher && !$CPAN::Config->{auto_commit}) {
$CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ".
"make the config permanent!\n");
} else {
- CPAN::HandleConfig->commit;
- }
-
- if (! $matcher) {
- $CPAN::Frontend->myprint(
- "\nYou can re-run configuration any time with 'o conf init' in the CPAN shell\n"
- );
+ CPAN::HandleConfig->commit($configpm);
}
-
}
-sub _local_lib_config {
- # Set environment stuff for this process
- require local::lib;
-
- # Tell user about environment vars to set
- $CPAN::Frontend->myprint($prompts{local_lib_installed});
- local $ENV{SHELL} = $CPAN::Config->{shell} || $ENV{SHELL};
- my $shellvars = local::lib->environment_vars_string_for(_local_lib_path());
- $CPAN::Frontend->myprint($shellvars);
-
- # Set %ENV after getting string above
- my %env = local::lib->build_environment_vars_for(_local_lib_path(), 1);
- while ( my ($k, $v) = each %env ) {
- $ENV{$k} = $v;
- }
-
- # Offer to mangle the shell config
- my $munged_rc;
- if ( my $rc = _find_shell_config() ) {
- local $auto_config = 0; # We *must* ask, even under autoconfig
- local *_real_prompt; # We *must* show prompt
- my $_conf = prompt(
- "\nWould you like me to append that to $rc now?", "yes"
- );
- if ($_conf =~ /^y/i) {
- open my $fh, ">>", $rc;
- print {$fh} "\n$shellvars";
- close $fh;
- $munged_rc++;
- }
- }
-
- # Warn at exit time
- if ($munged_rc) {
- push @{$CPAN::META->_exit_messages}, << "HERE";
-
-*** Remember to restart your shell before running cpan again ***
-HERE
- }
- else {
- push @{$CPAN::META->_exit_messages}, << "HERE";
-
-*** Remember to add these environment variables to your shell config
- and restart your shell before running cpan again ***
-
-$shellvars
-HERE
- }
-}
-
-{
- my %shell_rc_map = (
- map { $_ => ".${_}rc" } qw/ bash tcsh csh /,
- map { $_ => ".profile" } qw/dash ash sh/,
- zsh => ".zshenv",
- );
-
- sub _find_shell_config {
- my $shell = File::Basename::basename($CPAN::Config->{shell});
- if ( my $rc = $shell_rc_map{$shell} ) {
- my $path = File::Spec->catfile($ENV{HOME}, $rc);
- return $path if -w $path;
- }
- }
-}
-
-
-sub _local_lib_inc_path {
- return File::Spec->catdir(_local_lib_path(), qw/lib perl5/);
-}
+sub _init_external_progs {
+ my($matcher,$PATH) = @_;
+ my @external_progs = qw/bzip2 gzip tar unzip
-sub _local_lib_path {
- return File::Spec->catdir(_local_lib_home(), 'perl5');
-}
+ make
-# Adapted from resolve_home_path() in local::lib -- this is where
-# local::lib thinks the user's home is
-{
- my $local_lib_home;
- sub _local_lib_home {
- $local_lib_home ||= File::Spec->rel2abs( do {
- if ($CPAN::META->has_usable("File::HomeDir") && File::HomeDir->VERSION >= 0.65) {
- File::HomeDir->my_home;
- } elsif (defined $ENV{HOME}) {
- $ENV{HOME};
- } else {
- (getpwuid $<)[7] || "~";
- }
- });
- }
-}
+ curl lynx wget ncftpget ncftp ftp
-sub _do_pick_mirrors {
- local *_real_prompt;
- *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
- $CPAN::Frontend->myprint($prompts{urls_intro});
- # Only prompt for auto-pick if Net::Ping is new enough to do timings
- my $_conf = 'n';
- if ( $CPAN::META->has_usable("Net::Ping") && Net::Ping->VERSION gt '2.13') {
- $_conf = prompt($prompts{auto_pick}, "yes");
- } else {
- prompt("Autoselection disabled due to Net::Ping missing or insufficient. Please press ENTER");
- }
- my @old_list = @{ $CPAN::Config->{urllist} };
- if ( $_conf =~ /^y/i ) {
- conf_sites( auto_pick => 1 ) or bring_your_own();
- }
- else {
- _print_urllist('Current') if @old_list;
- my $msg = scalar @old_list
- ? "\nWould you like to edit the urllist or pick new mirrors from a list?"
- : "\nWould you like to pick from the CPAN mirror list?" ;
- my $_conf = prompt($msg, "yes");
- if ( $_conf =~ /^y/i ) {
- conf_sites();
- }
- bring_your_own();
- }
- _print_urllist('New');
-}
-
-sub _init_external_progs {
- my($matcher,$args) = @_;
- my $PATH = $args->{path};
- my @external_progs = @{ $args->{progs} };
- my $shortcut = $args->{shortcut};
- my $showed_make_warning;
+ gpg
+ patch applypatch
+ /;
if (!$matcher or "@external_progs" =~ /$matcher/) {
+ $CPAN::Frontend->myprint($prompts{external_progs}) unless $silent;
+
my $old_warn = $^W;
local $^W if $^O eq 'MacOS';
local $^W = $old_warn;
@@ -1498,64 +1276,15 @@ sub _init_external_progs {
$path ||= find_exe($progcall,$PATH);
unless ($path) { # not -e $path, because find_exe already checked that
local $"=";";
- $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n") unless $auto_config;
- _beg_for_make(), $showed_make_warning++ if $progname eq "make";
- }
- $prompts{$progname} = "Where is your $progname program?";
- $path = my_dflt_prompt($progname,$path,$matcher,1); # 1 => no strip spaces
- my $disabling = $path =~ m/^\s*$/;
-
- # don't let them disable or misconfigure make without warning
- if ( $progname eq "make" && ( $disabling || ! _check_found($path) ) ) {
- if ( $disabling && $showed_make_warning ) {
- next;
- }
- else {
- _beg_for_make() unless $showed_make_warning++;
- undef $CPAN::Config->{$progname};
- $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable make (NOT RECOMMENDED)\n");
- redo;
- }
- }
- elsif ( $disabling ) {
- next;
- }
- elsif ( _check_found( $CPAN::Config->{$progname} ) ) {
- last if $shortcut && !$matcher;
- }
- else {
- undef $CPAN::Config->{$progname};
- $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable $progname\n");
- redo;
- }
- }
- }
-}
-
-sub _check_found {
- my ($prog) = @_;
- if ( ! -f $prog ) {
- $CPAN::Frontend->mywarn("Warning: '$prog' does not exist\n")
- unless $auto_config;
- return;
- }
- elsif ( ! -x $prog ) {
- $CPAN::Frontend->mywarn("Warning: '$prog' is not executable\n")
- unless $auto_config;
- return;
- }
- return 1;
-}
-
-sub _beg_for_make {
- $CPAN::Frontend->mywarn(<<"HERE");
-
-ALERT: 'make' is an essential tool for building perl Modules.
-Please make sure you have 'make' (or some equivalent) working.
-
-HERE
- if ($^O eq "MSWin32") {
- $CPAN::Frontend->mywarn(<<"HERE");
+ $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n") unless $silent;
+ if ($progname eq "make") {
+ $CPAN::Frontend->mywarn("ALERT: 'make' is an essential tool for ".
+ "building perl Modules. Please make sure you ".
+ "have 'make' (or some equivalent) ".
+ "working.\n"
+ );
+ if ($^O eq "MSWin32") {
+ $CPAN::Frontend->mywarn("
Windows users may want to follow this procedure when back in the CPAN shell:
look YVES/scripts/alien_nmake.pl
@@ -1566,30 +1295,39 @@ substitute. You can then revisit this dialog with
o conf init make
-HERE
- }
+");
+ }
+ }
+ }
+ $prompts{$progname} = "Where is your $progname program?";
+ my_dflt_prompt($progname,$path,$matcher);
+ }
+ }
}
sub init_cpan_home {
my($matcher) = @_;
if (!$matcher or 'cpan_home' =~ /$matcher/) {
- my $cpan_home =
- $CPAN::Config->{cpan_home} || CPAN::HandleConfig::cpan_home();
+ my $cpan_home = $CPAN::Config->{cpan_home}
+ || File::Spec->catdir(CPAN::HandleConfig::home(), ".cpan");
+
if (-d $cpan_home) {
- $CPAN::Frontend->myprint(
- "\nI see you already have a directory\n" .
- "\n$cpan_home\n" .
- "Shall we use it as the general CPAN build and cache directory?\n\n"
- ) unless $auto_config;
+ $CPAN::Frontend->myprint(qq{
+
+I see you already have a directory
+ $cpan_home
+Shall we use it as the general CPAN build and cache directory?
+
+}) unless $silent;
} else {
# no cpan-home, must prompt and get one
- $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $auto_config;
+ $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $silent;
}
my $default = $cpan_home;
my $loop = 0;
my($last_ans,$ans);
- $CPAN::Frontend->myprint(" <cpan_home>\n") unless $auto_config;
+ $CPAN::Frontend->myprint(" <cpan_home>\n") unless $silent;
PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) {
if (File::Spec->file_name_is_absolute($ans)) {
my @cpan_home = split /[\/\\]/, $ans;
@@ -1634,21 +1372,18 @@ sub init_cpan_home {
}
sub my_dflt_prompt {
- my ($item, $dflt, $m, $no_strip) = @_;
+ my ($item, $dflt, $m) = @_;
my $default = $CPAN::Config->{$item} || $dflt;
- if (!$auto_config && (!$m || $item =~ /$m/)) {
+ if (!$silent && (!$m || $item =~ /$m/)) {
if (my $intro = $prompts{$item . "_intro"}) {
$CPAN::Frontend->myprint($intro);
}
$CPAN::Frontend->myprint(" <$item>\n");
- $CPAN::Config->{$item} =
- $no_strip ? prompt_no_strip($prompts{$item}, $default)
- : prompt( $prompts{$item}, $default);
+ $CPAN::Config->{$item} = prompt($prompts{$item}, $default);
} else {
$CPAN::Config->{$item} = $default;
}
- return $CPAN::Config->{$item};
}
sub my_yn_prompt {
@@ -1657,7 +1392,7 @@ sub my_yn_prompt {
defined($default = $CPAN::Config->{$item}) or $default = $dflt;
# $DB::single = 1;
- if (!$auto_config && (!$m || $item =~ /$m/)) {
+ if (!$silent && (!$m || $item =~ /$m/)) {
if (my $intro = $prompts{$item . "_intro"}) {
$CPAN::Frontend->myprint($intro);
}
@@ -1674,7 +1409,7 @@ sub my_prompt_loop {
my $default = $CPAN::Config->{$item} || $dflt;
my $ans;
- if (!$auto_config && (!$m || $item =~ /$m/)) {
+ if (!$silent && (!$m || $item =~ /$m/)) {
$CPAN::Frontend->myprint($prompts{$item . "_intro"});
$CPAN::Frontend->myprint(" <$item>\n");
do { $ans = prompt($prompts{$item}, $default);
@@ -1696,7 +1431,7 @@ sub my_prompt_loop {
# (2) We don't have a copy at all
# (2a) If we are allowed to connect, we try to get a new copy. If it succeeds,
# we use it, otherwise, we warn about failure
-# (2b) If we aren't allowed to connect,
+# (2b) If we aren't allowed to connect,
sub conf_sites {
my %args = @_;
@@ -1771,7 +1506,7 @@ HERE
}
else {
$CPAN::Frontend->mywarn(<<'HERE');
-You will need to provide CPAN mirror URLs yourself or set
+You will need to provide CPAN mirror URLs yourself or set
'o conf connect_to_internet_ok 1' and try again.
HERE
}
@@ -1789,7 +1524,6 @@ HERE
sub find_exe {
my($exe,$path) = @_;
- $path ||= [split /$Config{'path_sep'}/, $ENV{'PATH'}];
my($dir);
#warn "in find_exe exe[$exe] path[@$path]";
for $dir (@$path) {
@@ -1877,7 +1611,7 @@ sub display_some {
for my $item (@displayable) {
$CPAN::Frontend->myprint(sprintf "(%d) %s\n", ++$pos, $item);
}
- my $hit_what = $default ? "SPACE ENTER" : "ENTER";
+ my $hit_what = $default ? "SPACE RETURN" : "RETURN";
$CPAN::Frontend->myprint(sprintf("%d more items, hit %s to show them\n",
(@$items - $pos),
$hit_what,
@@ -1889,23 +1623,17 @@ sub display_some {
sub auto_mirrored_by {
my $local = shift or return;
local $|=1;
- $CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n");
+ $CPAN::Frontend->myprint("Searching for the best CPAN mirrors (please be patient) ...");
my $mirrors = CPAN::Mirrors->new($local);
-
my $cnt = 0;
my @best = $mirrors->best_mirrors(
- how_many => 3,
- callback => sub {
- $CPAN::Frontend->myprint(".");
- if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); }
- },
+ how_many => 5,
+ callback => sub { $CPAN::Frontend->myprint(".") },
);
-
- my $urllist = [ map { $_->http } @best ];
+ my $urllist = [ map { $_->ftp } @best ];
push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
$CPAN::Frontend->myprint(" done!\n\n");
-
- return $urllist
+ return $urllist;
}
sub choose_mirrored_by {
@@ -1976,7 +1704,7 @@ put them on one line, separated by blanks, hyphenated ranges allowed
if (@previous_urls) {
$default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) ..
(scalar @urls));
- $prompt .= "\n(or just hit ENTER to keep your previous picks)";
+ $prompt .= "\n(or just hit RETURN to keep your previous picks)";
}
@urls = picklist (\@urls, $prompt, $default);
@@ -1990,12 +1718,13 @@ sub bring_your_own {
my($ans,@urls);
my $eacnt = 0; # empty answers
$CPAN::Frontend->myprint(<<'HERE');
+
Now you can enter your own CPAN URLs by hand. A local CPAN mirror can be
listed using a 'file:' URL like 'file:///path/to/cpan/'
HERE
do {
- my $prompt = "Enter another URL or ENTER to quit:";
+ my $prompt = "Enter another URL or RETURN to quit:";
unless (%seen) {
$prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from.
@@ -2038,33 +1767,12 @@ later if you\'re sure it\'s right.\n},
}
sub _print_urllist {
- my ($which) = @_;
- $CPAN::Frontend->myprint("$which urllist\n");
- for ( @{$CPAN::Config->{urllist} || []} ) {
- $CPAN::Frontend->myprint(" $_\n")
+ $CPAN::Frontend->myprint("New urllist\n");
+ for ( @{$CPAN::Config->{urllist} || []} ) {
+ $CPAN::Frontend->myprint(" $_\n")
};
}
-sub _can_write_to_libdirs {
- return -w $Config{installprivlib}
- && -w $Config{installarchlib}
- && -w $Config{installsitelib}
- && -w $Config{installsitearch}
-}
-
-sub _using_installbase {
- return 1 if $ENV{PERL_MM_OPT} && $ENV{PERL_MM_OPT} =~ /install_base/i;
- return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /install_base/i }
- qw(makepl_arg make_install_arg mbuildpl_arg mbuild_install_arg);
- return;
-}
-
-sub _using_sudo {
- return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /sudo/ }
- qw(make_install_make_command mbuild_install_build_command);
- return;
-}
-
sub _strip_spaces {
$_[0] =~ s/^\s+//; # no leading spaces
$_[0] =~ s/\s+\z//; # no trailing spaces
@@ -2077,16 +1785,13 @@ sub prompt ($;$) {
my $ans = _real_prompt(@_);
_strip_spaces($ans);
- $CPAN::Frontend->myprint("\n") unless $auto_config;
+ $CPAN::Frontend->myprint("\n");
return $ans;
}
sub prompt_no_strip ($;$) {
- unless (defined &_real_prompt) {
- *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
- }
return _real_prompt(@_);
}
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm
index a138128bdfe..76cd81eee8b 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm
@@ -1,18 +1,8 @@
package CPAN::HandleConfig;
use strict;
use vars qw(%can %keys $loading $VERSION);
-use File::Path ();
-use File::Spec ();
-use File::Basename ();
-use Carp ();
-=head1 NAME
-
-CPAN::HandleConfig - internal configuration handling for CPAN.pm
-
-=cut
-
-$VERSION = "5.5005"; # see also CPAN::Config::VERSION at end of file
+$VERSION = "5.5001"; # see also CPAN::Config::VERSION at end of file
%can = (
commit => "Commit changes to disk",
@@ -22,8 +12,8 @@ $VERSION = "5.5005"; # see also CPAN::Config::VERSION at end of file
);
# Q: where is the "How do I add a new config option" HOWTO?
-# A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f]
-# A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f]
+# A1: svn diff -r 757:758 # where dagolden added test_report
+# A2: svn diff -r 985:986 # where andk added yaml_module
# A3: 1. add new config option to %keys below
# 2. add a Pod description in CPAN::FirstTime; it should include a
# prompt line; see others for examples
@@ -88,20 +78,17 @@ $VERSION = "5.5005"; # see also CPAN::Config::VERSION at end of file
"patch",
"patches_dir",
"perl5lib_verbosity",
- "prefer_external_tar",
"prefer_installer",
"prefs_dir",
"prerequisites_policy",
"proxy_pass",
"proxy_user",
"randomize_urllist",
- "recommends_policy",
"scan_cache",
"shell",
"show_unparsable_versions",
"show_upload_date",
"show_zero_versions",
- "suggests_policy",
"tar",
"tar_verbosity",
"term_is_latin",
@@ -110,7 +97,6 @@ $VERSION = "5.5005"; # see also CPAN::Config::VERSION at end of file
"trust_test_report_history",
"unzip",
"urllist",
- "use_prompt_default",
"use_sqlite",
"username",
"version_timeout",
@@ -268,21 +254,17 @@ sub prettyprint {
}
}
-# generally, this should be called without arguments so that the currently
-# loaded config file is where changes are committed.
sub commit {
my($self,@args) = @_;
CPAN->debug("args[@args]") if $CPAN::DEBUG;
if ($CPAN::RUN_DEGRADED) {
- $CPAN::Frontend->mydie(
- "'o conf commit' disabled in ".
- "degraded mode. Maybe try\n".
- " !undef \$CPAN::RUN_DEGRADED\n"
- );
+ $CPAN::Frontend->mydie(
+ "'o conf commit' disabled in ".
+ "degraded mode. Maybe try\n".
+ " !undef \$CPAN::RUN_DEGRADED\n"
+ );
}
- my ($configpm, $must_reload);
-
- # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
+ my $configpm;
if (@args) {
if ($args[0] eq "args") {
# we have not signed that contract
@@ -290,50 +272,31 @@ sub commit {
$configpm = $args[0];
}
}
-
- # use provided name or the current config or create a new MyConfig
- $configpm ||= require_myconfig_or_config() || make_new_config();
-
- # commit to MyConfig if we can't write to Config
- if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
- my $myconfig = _new_config_name();
- $CPAN::Frontend->mywarn(
- "Your $configpm file\n".
- "is not writable. I will attempt to write your configuration to\n" .
- "$myconfig instead.\n\n"
- );
- $configpm = make_new_config();
- $must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
+ unless (defined $configpm) {
+ $configpm ||= $INC{"CPAN/MyConfig.pm"};
+ $configpm ||= $INC{"CPAN/Config.pm"};
+ $configpm || Carp::confess(q{
+CPAN::Config::commit called without an argument.
+Please specify a filename where to save the configuration or try
+"o conf init" to have an interactive course through configing.
+});
}
-
- # XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
my($mode);
if (-f $configpm) {
$mode = (stat $configpm)[2];
if ($mode && ! -w _) {
- _die_cant_write_config($configpm);
+ Carp::confess("$configpm is not writable");
}
}
- $self->_write_config_file($configpm);
- require_myconfig_or_config() if $must_reload;
-
- #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
- #chmod $mode, $configpm;
-###why was that so? $self->defaults;
- $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
- $CPAN::CONFIG_DIRTY = 0;
- 1;
-}
-
-sub _write_config_file {
- my ($self, $configpm) = @_;
my $msg;
- $msg = <<EOF if $configpm =~ m{CPAN/Config\.pm};
+ my $home = home();
+ $msg = <<EOF unless $configpm =~ /MyConfig/;
# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
-# configuration file.
+# configuration file. The user-config file is being looked for as
+# $home/.cpan/CPAN/MyConfig.pm.
EOF
$msg ||= "\n";
@@ -354,13 +317,18 @@ EOF
",\n"
);
}
+
$fh->print("};\n1;\n__END__\n");
close $fh;
- return;
+ #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ #chmod $mode, $configpm;
+###why was that so? $self->defaults;
+ $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
+ $CPAN::CONFIG_DIRTY = 0;
+ 1;
}
-
# stolen from MakeMaker; not taking the original because it is buggy;
# bugreport will have to say: keys of hashes remain unquoted and can
# produce syntax errors
@@ -470,178 +438,154 @@ else: quote it with the correct quote type for the box we're on
sub init {
my($self,@args) = @_;
CPAN->debug("self[$self]args[".join(",",@args)."]");
- $self->load(do_init => 1, @args);
+ $self->load(doit => 1, @args);
1;
}
-# Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file
-# if already loaded. Returns the path to the file %INC or else the empty string
+# This is a piece of repeated code that is abstracted here for
+# maintainability. RMB
#
-# Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently
-# created, calling this again will leave *both* in %INC
-
-sub require_myconfig_or_config () {
- if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
- return $INC{"CPAN/MyConfig.pm"};
- }
- elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
- return $INC{"CPAN/Config.pm"};
- }
- else {
- return q{};
- }
+sub _configpmtest {
+ my($configpmdir, $configpmtest) = @_;
+ if (-w $configpmtest) {
+ return $configpmtest;
+ } elsif (-w $configpmdir) {
+ #_#_# following code dumped core on me with 5.003_11, a.k.
+ my $configpm_bak = "$configpmtest.bak";
+ unlink $configpm_bak if -f $configpm_bak;
+ if( -f $configpmtest ) {
+ if( rename $configpmtest, $configpm_bak ) {
+ $CPAN::Frontend->mywarn(<<END);
+Old configuration file $configpmtest
+ moved to $configpm_bak
+END
+ }
+ }
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpmtest")) {
+ $fh->print("1;\n");
+ return $configpmtest;
+ } else {
+ # Should never happen
+ Carp::confess("Cannot open >$configpmtest");
+ }
+ } else { return }
}
-# Load a module, but ignore "can't locate..." errors
-# Optionally take a list of directories to add to @INC for the load
-sub _try_loading {
- my ($module, @dirs) = @_;
- (my $file = $module) =~ s{::}{/}g;
- $file .= ".pm";
-
+sub require_myconfig_or_config () {
+ return if $INC{"CPAN/MyConfig.pm"};
local @INC = @INC;
- for my $dir ( @dirs ) {
- if ( -f File::Spec->catfile($dir, $file) ) {
- unshift @INC, $dir;
- last;
- }
- }
-
- eval { require $file };
+ my $home = home();
+ unshift @INC, File::Spec->catdir($home,'.cpan');
+ eval { require CPAN::MyConfig };
my $err_myconfig = $@;
- if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
- die "Error while requiring ${module}:\n$err_myconfig";
+ if ($err_myconfig and $err_myconfig !~ m#locate CPAN/MyConfig\.pm#) {
+ die "Error while requiring CPAN::MyConfig:\n$err_myconfig";
+ }
+ unless ($INC{"CPAN/MyConfig.pm"}) { # this guy has settled his needs already
+ eval {require CPAN::Config;}; # not everybody has one
+ my $err_config = $@;
+ if ($err_config and $err_config !~ m#locate CPAN/Config\.pm#) {
+ die "Error while requiring CPAN::Config:\n$err_config";
+ }
}
- return $INC{$file};
}
-# prioritized list of possible places for finding "CPAN/MyConfig.pm"
-sub cpan_home_dir_candidates {
- my @dirs;
+sub home () {
+ my $home;
+ # Suppress load messages until we load the config and know whether
+ # load messages are desired. Otherwise, it's unexpected and odd
+ # why one load message pops up even when verbosity is turned off.
+ # This means File::HomeDir load messages are never seen, but I
+ # think that's probably OK -- DAGOLDEN
+
+ # 5.6.2 seemed to segfault localizing a value in a hashref
+ # so do it manually instead
my $old_v = $CPAN::Config->{load_module_verbosity};
$CPAN::Config->{load_module_verbosity} = q[none];
- if ($CPAN::META->has_usable('File::HomeDir')) {
- if ($^O ne 'darwin') {
- push @dirs, File::HomeDir->my_data;
- # my_data is ~/Library/Application Support on darwin,
- # which causes issues in the toolchain.
+ if ($CPAN::META->has_usable("File::HomeDir")) {
+ if ($^O eq 'darwin') {
+ $home = File::HomeDir->my_home; # my_data is ~/Library/Application Support on darwin,
+ # which causes issues in the toolchain.
}
- push @dirs, File::HomeDir->my_home;
+ else {
+ $home = File::HomeDir->my_data || File::HomeDir->my_home;
+ }
+ }
+ unless (defined $home) {
+ $home = $ENV{HOME};
}
- # Windows might not have HOME, so check it first
- push @dirs, $ENV{HOME} if $ENV{HOME};
- # Windows might have these instead
- push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
- if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
- push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};
-
$CPAN::Config->{load_module_verbosity} = $old_v;
- my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
- @dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
- return wantarray ? @dirs : $dirs[0];
+ $home;
}
sub load {
my($self, %args) = @_;
- $CPAN::Be_Silent+=0; # protect against 'used only once'
- $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
- my $do_init = delete $args{do_init} || 0;
- my $make_myconfig = delete $args{make_myconfig};
+ $CPAN::Be_Silent++ if $args{be_silent};
+ my $doit;
+ $doit = delete $args{doit} || 0;
$loading = 0 unless defined $loading;
- my $configpm = require_myconfig_or_config;
+ use Carp;
+ require_myconfig_or_config;
my @miss = $self->missing_config_data;
- CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
- return unless $do_init || @miss;
-
- # I'm not how we'd ever wind up in a recursive loop, but I'm leaving
- # this here for safety's sake -- dagolden, 2011-01-19
+ CPAN->debug("doit[$doit]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
+ return unless $doit || @miss;
return if $loading;
local $loading = ($loading||0) + 1;
- # Warn if we have a config file, but things were found missing
- if ($configpm && @miss && !$do_init) {
- if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
- $configpm = make_new_config();
- $CPAN::Frontend->myprint(<<END);
-The system CPAN configuration file has provided some default values,
-but you need to complete the configuration dialog for CPAN.pm.
-Configuration will be written to
- <<$configpm>>
-END
- }
- else {
- $CPAN::Frontend->myprint(<<END);
-Sorry, we have to rerun the configuration dialog for CPAN.pm due to
-some missing parameters. Configuration will be written to
- <<$configpm>>
-
-END
- }
- }
-
require CPAN::FirstTime;
- return CPAN::FirstTime::init($configpm || make_new_config(), %args);
-}
-
-# Creates a new, empty config file at the preferred location
-# Any existing will be renamed with a ".bak" suffix if possible
-# If the file cannot be created, an exception is thrown
-sub make_new_config {
- my $configpm = _new_config_name();
- my $configpmdir = File::Basename::dirname( $configpm );
- File::Path::mkpath($configpmdir) unless -d $configpmdir;
-
- if ( -w $configpmdir ) {
- #_#_# following code dumped core on me with 5.003_11, a.k.
- if( -f $configpm ) {
- my $configpm_bak = "$configpm.bak";
- unlink $configpm_bak if -f $configpm_bak;
- if( rename $configpm, $configpm_bak ) {
- $CPAN::Frontend->mywarn(<<END);
-Old configuration file $configpm
- moved to $configpm_bak
-END
- }
+ my($redo,$configpm,$fh);
+ if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
+ $configpm = $INC{"CPAN/Config.pm"};
+ $redo++;
+ } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
+ $configpm = $INC{"CPAN/MyConfig.pm"};
+ $redo++;
+ } else {
+ my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
+ my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
+ my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
+ my $inc_key;
+ if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
+ $configpm = _configpmtest($configpmdir,$configpmtest);
+ $inc_key = "CPAN/Config.pm";
}
- my $fh = FileHandle->new;
- if ($fh->open(">$configpm")) {
- $fh->print("1;\n");
- return $configpm;
+ unless ($configpm) {
+ $configpmdir = File::Spec->catdir(home,".cpan","CPAN");
+ File::Path::mkpath($configpmdir);
+ $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
+ $configpm = _configpmtest($configpmdir,$configpmtest);
+ $inc_key = "CPAN/MyConfig.pm";
}
- }
- _die_cant_write_config($configpm);
-}
-
-sub _die_cant_write_config {
- my ($configpm) = @_;
- $CPAN::Frontend->mydie(<<"END");
-WARNING: CPAN.pm is unable to write a configuration file. You
-must be able to create and write to '$configpm'.
+ if ($configpm) {
+ $INC{$inc_key} = $configpm;
+ } else {
+ my $myconfigpm = File::Spec->catfile(home,".cpan","CPAN","MyConfig.pm");
+ $CPAN::Frontend->mydie(<<"END");
+WARNING: CPAN.pm is unable to write a configuration file. You need write
+access to your default perl library directories or you must be able to
+create and write to '$myconfigpm'.
Aborting configuration.
END
+ }
-}
-
-# From candidate directories, we would like (in descending preference order):
-# * the one that contains a MyConfig file
-# * one that exists (even without MyConfig)
-# * the first one on the list
-sub cpan_home {
- my @dirs = cpan_home_dir_candidates();
- for my $d (@dirs) {
- return $d if -f "$d/CPAN/MyConfig.pm";
}
- for my $d (@dirs) {
- return $d if -d $d;
+ local($") = ", ";
+ if ($redo && !$doit) {
+ $CPAN::Frontend->myprint(<<END);
+Sorry, we have to rerun the configuration dialog for CPAN.pm due to
+some missing parameters... Will write to
+ <<$configpm>>
+
+END
+ $args{args} = \@miss;
}
- return $dirs[0];
+ my $initialized = CPAN::FirstTime::init($configpm, %args);
+ return $initialized;
}
-sub _new_config_name {
- return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm');
-}
# returns mandatory but missing entries in the Config
sub missing_config_data {
@@ -768,7 +712,7 @@ sub prefs_lookup {
use strict;
use vars qw($AUTOLOAD $VERSION);
- $VERSION = "5.5005";
+ $VERSION = "5.5001";
# formerly CPAN::HandleConfig was known as CPAN::Config
sub AUTOLOAD { ## no critic
@@ -795,4 +739,3 @@ modify it under the same terms as Perl itself.
# mode: cperl
# cperl-indent-level: 4
# End:
-# vim: ts=4 sts=4 sw=4:
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Index.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Index.pm
index 8205d78bd02..9df757de706 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Index.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Index.pm
@@ -1,11 +1,11 @@
package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
-$VERSION = "1.9601";
+$VERSION = "1.94";
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
-# use constant PROTOCOL => "2.0"; # commented out to avoid warning on upgrade from 1.57
+# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
sub PROTOCOL { 2.0 }
#-> sub CPAN::Index::force_reload ;
@@ -123,75 +123,74 @@ sub reanimate_build_dir {
my $i = 0;
my $painted = 0;
my $restored = 0;
- my $start = CPAN::FTP::_mytime();
my @candidates = map { $_->[0] }
sort { $b->[1] <=> $a->[1] }
map { [ $_, -M File::Spec->catfile($d,$_) ] }
- grep {/(.+)\.yml$/ && -d File::Spec->catfile($d,$1)} readdir $dh;
- if ( @candidates ) {
- $CPAN::Frontend->myprint
- (sprintf("Reading %d yaml file%s from %s/\n",
- scalar @candidates,
- @candidates==1 ? "" : "s",
- $CPAN::Config->{build_dir}
- ));
- DISTRO: for $i (0..$#candidates) {
- my $dirent = $candidates[$i];
- my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
- if ($@) {
- warn "Error while parsing file '$dirent'; error: '$@'";
- next DISTRO;
- }
- my $c = $y->[0];
- if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
- my $key = $c->{distribution}{ID};
- for my $k (keys %{$c->{distribution}}) {
- if ($c->{distribution}{$k}
- && ref $c->{distribution}{$k}
- && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
- $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
- }
+ grep {/\.yml$/} readdir $dh;
+ unless (@candidates) {
+ $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
+ return;
+ }
+ $CPAN::Frontend->myprint
+ (sprintf("Going to read %d yaml file%s from %s/\n",
+ scalar @candidates,
+ @candidates==1 ? "" : "s",
+ $CPAN::Config->{build_dir}
+ ));
+ my $start = CPAN::FTP::_mytime();
+ DISTRO: for $i (0..$#candidates) {
+ my $dirent = $candidates[$i];
+ my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
+ if ($@) {
+ warn "Error while parsing file '$dirent'; error: '$@'";
+ next DISTRO;
+ }
+ my $c = $y->[0];
+ if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
+ my $key = $c->{distribution}{ID};
+ for my $k (keys %{$c->{distribution}}) {
+ if ($c->{distribution}{$k}
+ && ref $c->{distribution}{$k}
+ && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
+ $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
}
+ }
- #we tried to restore only if element already
- #exists; but then we do not work with metadata
- #turned off.
- my $do
- = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
- = $c->{distribution};
- for my $skipper (qw(
- badtestcnt
- configure_requires_later
- configure_requires_later_for
- force_update
- later
- later_for
- notest
- should_report
- sponsored_mods
- prefs
- negative_prefs_cache
- )) {
- delete $do->{$skipper};
- }
- if ($do->can("tested_ok_but_not_installed")) {
- if ($do->tested_ok_but_not_installed) {
- $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
- } else {
- next DISTRO;
- }
- }
- $restored++;
+ #we tried to restore only if element already
+ #exists; but then we do not work with metadata
+ #turned off.
+ my $do
+ = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
+ = $c->{distribution};
+ for my $skipper (qw(
+ badtestcnt
+ configure_requires_later
+ configure_requires_later_for
+ force_update
+ later
+ later_for
+ notest
+ should_report
+ sponsored_mods
+ prefs
+ negative_prefs_cache
+ )) {
+ delete $do->{$skipper};
}
- $i++;
- while (($painted/76) < ($i/@candidates)) {
- $CPAN::Frontend->myprint(".");
- $painted++;
+ if ($do->can("tested_ok_but_not_installed")) {
+ if ($do->tested_ok_but_not_installed) {
+ $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
+ } else {
+ next DISTRO;
+ }
}
+ $restored++;
+ }
+ $i++;
+ while (($painted/76) < ($i/@candidates)) {
+ $CPAN::Frontend->myprint(".");
+ $painted++;
}
- }
- else {
- $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
}
my $took = CPAN::FTP::_mytime() - $start;
$CPAN::Frontend->myprint(sprintf(
@@ -232,7 +231,7 @@ sub rd_authindex {
return unless defined $index_target;
return if CPAN::_sqlite_running();
my @lines;
- $CPAN::Frontend->myprint("Reading '$index_target'\n");
+ $CPAN::Frontend->myprint("Going to read '$index_target'\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
local($/) = "\n";
@@ -272,7 +271,7 @@ sub rd_modpacks {
my($self, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
- $CPAN::Frontend->myprint("Reading '$index_target'\n");
+ $CPAN::Frontend->myprint("Going to read '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
@@ -293,7 +292,6 @@ sub rd_modpacks {
$shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
}
CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
- my $errors = 0;
if (not defined $line_count) {
$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
@@ -301,7 +299,7 @@ Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
- $errors++;
+
$CPAN::Frontend->mysleep(5);
} elsif ($line_count != scalar @lines) {
@@ -319,7 +317,7 @@ Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
- $errors++;
+
$CPAN::Frontend->mysleep(5);
} else {
@@ -373,19 +371,14 @@ happen.\a
my(%exists);
my $i = 0;
my $painted = 0;
- LINE: foreach (@lines) {
+ foreach (@lines) {
# before 1.56 we split into 3 and discarded the rest. From
# 1.57 we assign remaining text to $comment thus allowing to
# influence isa_perl
my($mod,$version,$dist,$comment) = split " ", $_, 4;
unless ($mod && defined $version && $dist) {
- require Dumpvalue;
- my $dv = Dumpvalue->new(tick => '"');
- $CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_));
- if ($errors++ >= 5){
- $CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors");
- }
- next LINE;
+ $CPAN::Frontend->mywarn("Could not split line[$_]\n");
+ next;
}
my($bundle,$id,$userid);
@@ -495,7 +488,7 @@ sub rd_modlist {
my($cl,$index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
- $CPAN::Frontend->myprint("Reading '$index_target'\n");
+ $CPAN::Frontend->myprint("Going to read '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
my $slurp = "";
@@ -557,7 +550,7 @@ sub write_metadata_cache {
$cache->{last_time} = $LAST_TIME;
$cache->{DATE_OF_02} = $DATE_OF_02;
$cache->{PROTOCOL} = PROTOCOL;
- $CPAN::Frontend->myprint("Writing $metadata_file\n");
+ $CPAN::Frontend->myprint("Going to write $metadata_file\n");
eval { Storable::nstore($cache, $metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}
@@ -570,7 +563,7 @@ sub read_metadata_cache {
return unless $CPAN::META->has_usable("Storable");
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
return unless -r $metadata_file and -f $metadata_file;
- $CPAN::Frontend->myprint("Reading '$metadata_file'\n");
+ $CPAN::Frontend->myprint("Going to read '$metadata_file'\n");
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/LWP/UserAgent.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/LWP/UserAgent.pm
index fe8bf27a4a9..7bb86f9a15d 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/LWP/UserAgent.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/LWP/UserAgent.pm
@@ -3,11 +3,9 @@
package CPAN::LWP::UserAgent;
use strict;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
-use CPAN::HTTP::Credentials;
# we delay requiring LWP::UserAgent and setting up inheritance until we need it
-$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9601";
-
+$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.94";
sub config {
return if $SETUPDONE;
@@ -22,20 +20,94 @@ sub config {
sub get_basic_credentials {
my($self, $realm, $uri, $proxy) = @_;
+ if ($USER && $PASSWD) {
+ return ($USER, $PASSWD);
+ }
if ( $proxy ) {
- return CPAN::HTTP::Credentials->get_proxy_credentials();
+ ($USER,$PASSWD) = $self->get_proxy_credentials();
} else {
- return CPAN::HTTP::Credentials->get_non_proxy_credentials();
+ ($USER,$PASSWD) = $self->get_non_proxy_credentials();
}
+ return($USER,$PASSWD);
}
-sub no_proxy {
- my ( $self, $no_proxy ) = @_;
- return $self->SUPER::no_proxy( split(',',$no_proxy) );
+sub get_proxy_credentials {
+ my $self = shift;
+ my ($user, $password);
+ if ( defined $CPAN::Config->{proxy_user} ) {
+ $user = $CPAN::Config->{proxy_user};
+ $password = $CPAN::Config->{proxy_pass} || "";
+ return ($user, $password);
+ }
+ my $username_prompt = "\nProxy authentication needed!
+ (Note: to permanently configure username and password run
+ o conf proxy_user your_username
+ o conf proxy_pass your_password
+ )\nUsername:";
+ ($user, $password) =
+ _get_username_and_password_from_user($username_prompt);
+ return ($user,$password);
+}
+
+sub get_non_proxy_credentials {
+ my $self = shift;
+ my ($user,$password);
+ if ( defined $CPAN::Config->{username} ) {
+ $user = $CPAN::Config->{username};
+ $password = $CPAN::Config->{password} || "";
+ return ($user, $password);
+ }
+ my $username_prompt = "\nAuthentication needed!
+ (Note: to permanently configure username and password run
+ o conf username your_username
+ o conf password your_password
+ )\nUsername:";
+
+ ($user, $password) =
+ _get_username_and_password_from_user($username_prompt);
+ return ($user,$password);
}
+sub _get_username_and_password_from_user {
+ my $username_message = shift;
+ my ($username,$password);
+
+ ExtUtils::MakeMaker->import(qw(prompt));
+ $username = prompt($username_message);
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("noecho");
+ }
+ else {
+ $CPAN::Frontend->mywarn(
+ "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
+ );
+ }
+ $password = prompt("Password:");
+
+ if ($CPAN::META->has_inst("Term::ReadKey")) {
+ Term::ReadKey::ReadMode("restore");
+ }
+ $CPAN::Frontend->myprint("\n\n");
+ return ($username,$password);
+}
+
+# mirror(): Its purpose is to deal with proxy authentication. When we
+# call SUPER::mirror, we relly call the mirror method in
+# LWP::UserAgent. LWP::UserAgent will then call
+# $self->get_basic_credentials or some equivalent and this will be
+# $self->dispatched to our own get_basic_credentials method.
+
+# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
+
+# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
+# although we have gone through our get_basic_credentials, the proxy
+# server refuses to connect. This could be a case where the username or
+# password has changed in the meantime, so I'm trying once again without
+# $USER and $PASSWD to give the get_basic_credentials routine another
+# chance to set $USER and $PASSWD.
+
# mirror(): Its purpose is to deal with proxy authentication. When we
-# call SUPER::mirror, we really call the mirror method in
+# call SUPER::mirror, we relly call the mirror method in
# LWP::UserAgent. LWP::UserAgent will then call
# $self->get_basic_credentials or some equivalent and this will be
# $self->dispatched to our own get_basic_credentials method.
@@ -53,7 +125,8 @@ sub mirror {
my($self,$url,$aslocal) = @_;
my $result = $self->SUPER::mirror($url,$aslocal);
if ($result->code == 407) {
- CPAN::HTTP::Credentials->clear_credentials;
+ undef $USER;
+ undef $PASSWD;
$result = $self->SUPER::mirror($url,$aslocal);
}
$result;
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm
index 37e7ce0ef9f..1a3402e8de5 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm
@@ -1,99 +1,39 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
-=head1 NAME
-
-CPAN::Mirrors - Get CPAN mirror information and select a fast one
-
-=head1 SYNOPSIS
-
- use CPAN::Mirrors;
-
- my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );
-
- my $seen = {};
-
- my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
- my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
-
- my $callback = sub {
- my( $m ) = @_;
- printf "%s = %s\n", $m->hostname, $m->rtt
- };
- $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback );
-
- @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
-
- print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
-
-=head1 DESCRIPTION
-
-=over
-
-=cut
-
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
-$VERSION = "1.9601";
+$VERSION = "1.77";
use Carp;
use FileHandle;
use Fcntl ":flock";
-use Net::Ping ();
-
-=item new( LOCAL_FILE_NAME )
-
-Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
-should look like that in http://www.cpan.org/MIRRORED.BY .
-
-=cut
sub new {
my ($class, $file) = @_;
- croak "CPAN::Mirrors->new requires a filename" unless defined $file;
- croak "The file [$file] was not found" unless -e $file;
-
- my $self = bless {
- mirrors => [],
- geography => {},
+ my $self = bless {
+ mirrors => [],
+ geography => {},
}, $class;
- $self->parse_mirrored_by( $file );
-
- return $self;
-}
-
-sub parse_mirrored_by {
- my ($self, $file) = @_;
my $handle = FileHandle->new;
- $handle->open($file)
+ $handle->open($file)
or croak "Couldn't open $file: $!";
flock $handle, LOCK_SH;
$self->_parse($file,$handle);
flock $handle, LOCK_UN;
$handle->close;
-}
-=item continents()
+ # populate continents & countries
-Return a list of continents based on those defined in F<MIRRORED.BY>.
-
-=cut
+ return $self
+}
sub continents {
my ($self) = @_;
return keys %{$self->{geography}};
}
-=item countries( [CONTINENTS] )
-
-Return a list of countries based on those defined in F<MIRRORED.BY>.
-It only returns countries for the continents you specify (as defined
-in C<continents>). If you don't specify any continents, it returns all
-of the countries listed in F<MIRRORED.BY>.
-
-=cut
-
sub countries {
my ($self, @continents) = @_;
@continents = $self->continents unless @continents;
@@ -104,15 +44,6 @@ sub countries {
return @countries;
}
-=item mirrors( [COUNTRIES] )
-
-Return a list of mirrors based on those defined in F<MIRRORED.BY>.
-It only returns mirrors for the countries you specify (as defined
-in C<countries>). If you don't specify any countries, it returns all
-of the mirrors listed in F<MIRRORED.BY>.
-
-=cut
-
sub mirrors {
my ($self, @countries) = @_;
return @{$self->{mirrors}} unless @countries;
@@ -124,337 +55,106 @@ sub mirrors {
return @found;
}
-=item get_mirrors_by_countries( [COUNTRIES] )
-
-A more sensible synonym for mirrors.
-
-=cut
-
-sub get_mirrors_by_countries { &mirrors }
-
-=item get_mirrors_by_continents( [CONTINENTS] )
-
-Return a list of mirrors for all of continents you specify. If you don't
-specify any continents, it returns all of the mirrors.
-
-You can specify a single continent or an array reference of continents.
-
-=cut
-
-sub get_mirrors_by_continents {
- my ($self, $continents ) = @_;
- $continents = [ $continents ] unless ref $continents;
-
- eval {
- $self->mirrors( $self->get_countries_by_continents( @$continents ) );
- };
- }
-
-=item get_countries_by_continents( [CONTINENTS] )
-
-A more sensible synonym for countries.
-
-=cut
-
-sub get_countries_by_continents { &countries }
-
-=item default_mirror
-
-Returns the default mirror, http://www.cpan.org/ . This mirror uses
-dynamic DNS to give a close mirror.
-
-=cut
-
-sub default_mirror { 'http://www.cpan.org/' }
-
-=item best_mirrors
-
-C<best_mirrors> checks for the best mirrors based on the list of
-continents you pass, or, without that, all continents, as defined
-by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
-C<how_many>. In list context, it returns up to C<how_many> mirror.
-In scalar context, it returns the single best mirror.
-
-Arguments
-
- how_many - the number of mirrors to return. Default: 1
- callback - a callback for find_best_continents
- verbose - true or false on all the whining and moaning. Default: false
- continents - an array ref of the continents to check
-
-If you don't specify the continents, C<best_mirrors> calls
-C<find_best_continents> to get the list of continents to check.
-
-If you don't have L<Net::Ping> v2.13 or later, needed for timings,
-this returns the default mirror.
-
-=cut
-
sub best_mirrors {
my ($self, %args) = @_;
- my $how_many = $args{how_many} || 1;
- my $callback = $args{callback};
- my $verbose = defined $args{verbose} ? $args{verbose} : 0;
- my $continents = $args{continents} || [];
- $continents = [$continents] unless ref $continents;
-
- # Old Net::Ping did not do timings at all
- my $min_version = '2.13';
- unless( Net::Ping->VERSION gt $min_version ) {
- carp sprintf "Net::Ping version is %s (< %s). Returning %s",
- Net::Ping->VERSION, $min_version, $self->default_mirror;
- return $self->default_mirror;
- }
+ my $how_many = $args{how_many} || 1;
+ my $callback = $args{callback};
+ my $verbose = $args{verbose};
+ my $conts = $args{continents} || [];
+ $conts = [$conts] unless ref $conts;
my $seen = {};
- if ( ! @$continents ) {
+ if ( ! @$conts ) {
print "Searching for the best continent ...\n" if $verbose;
- my @best_continents = $self->find_best_continents(
- seen => $seen,
- verbose => $verbose,
- callback => $callback,
- );
+ my @best = $self->_find_best_continent($seen, $verbose, $callback);
- # Only add enough continents to find enough mirrors
+ # how many continents to find enough mirrors? We should scan
+ # more than we need -- arbitrarily, we'll say x2
my $count = 0;
- for my $continent ( @best_continents ) {
- push @$continents, $continent;
- $count += $self->mirrors( $self->countries($continent) );
- last if $count >= $how_many;
+ for my $c ( @best ) {
+ push @$conts, $c;
+ $count += $self->mirrors( $self->countries($c) );
+ last if $count >= 2 * $how_many;
}
}
- print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
-
- my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
-
- my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback );
- return [] unless @$timings;
-
- $how_many = @$timings if $how_many > @$timings;
-
- return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
-}
-
-=item get_n_random_mirrors_by_continents( N, [CONTINENTS] )
-
-Returns up to N random mirrors for the specified continents. Specify the
-continents as an array reference.
-
-=cut
-
-sub get_n_random_mirrors_by_continents {
- my( $self, $n, $continents ) = @_;
- $n ||= 3;
- $continents = [ $continents ] unless ref $continents;
-
- if ( $n <= 0 ) {
- return wantarray ? () : [];
- }
-
- my @long_list = $self->get_mirrors_by_continents( $continents );
-
- if ( $n eq '*' or $n > @long_list ) {
- return wantarray ? @long_list : \@long_list;
- }
-
- @long_list = map {$_->[0]}
- sort {$a->[1] <=> $b->[1]}
- map {[$_, rand]} @long_list;
-
- splice @long_list, $n; # truncate
-
- \@long_list;
-}
-
-=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK );
-
-Pings the listed mirrors and returns a list of mirrors sorted in
-ascending ping times.
+ print "Scanning " . join(", ", @$conts) . " ...\n" if $verbose;
-C<MIRROR_LIST> is an anonymous array of C<CPAN::Mirrored::By> objects to
-ping.
-
-The optional argument C<SEEN> is a hash reference used to track the
-mirrors you've already pinged.
-
-The optional argument C<CALLBACK> is a subroutine reference to call
-after each ping. It gets the C<CPAN::Mirrored::By> object after each
-ping.
-
-=cut
-
-sub get_mirrors_timings {
- my( $self, $mirror_list, $seen, $callback ) = @_;
-
- $seen = {} unless defined $seen;
- croak "The mirror list argument must be an array reference"
- unless ref $mirror_list eq ref [];
- croak "The seen argument must be a hash reference"
- unless ref $seen eq ref {};
- croak "callback must be a subroutine"
- if( defined $callback and ref $callback ne ref sub {} );
-
- my $timings = [];
- for my $m ( @$mirror_list ) {
- $seen->{$m->hostname} = $m;
- next unless eval{ $m->http };
-
- if( $self->_try_a_ping( $seen, $m, ) ) {
- my $ping = $m->ping;
- next unless defined $ping;
- push @$timings, $m;
- $callback->( $m ) if $callback;
+ my @timings;
+ for my $m ($self->mirrors($self->countries(@$conts))) {
+ next unless $m->ftp;
+ my $hostname = $m->hostname;
+ if ( $seen->{$hostname} ) {
+ push @timings, $seen->{$hostname}
+ if defined $seen->{$hostname}[1];
}
else {
- push @$timings, $seen->{$m->hostname}
- if defined $seen->{$m->hostname}->rtt;
+ my $ping = $m->ping;
+ next unless defined $ping;
+ push @timings, [$m, $ping];
+ $callback->($m,$ping) if $callback;
}
}
+ return unless @timings;
+ $how_many = @timings if $how_many > @timings;
+ my @best =
+ map { $_->[0] }
+ sort { $a->[1] <=> $b->[1] } @timings;
- my @best = sort {
- if( defined $a->rtt and defined $b->rtt ) {
- $a->rtt <=> $b->rtt
- }
- elsif( defined $a->rtt and ! defined $b->rtt ) {
- return -1;
- }
- elsif( ! defined $a->rtt and defined $b->rtt ) {
- return 1;
- }
- elsif( ! defined $a->rtt and ! defined $b->rtt ) {
- return 0;
- }
-
- } @$timings;
-
- return wantarray ? @best : \@best;
+ return wantarray ? @best[0 .. $how_many-1] : $best[0];
}
-=item find_best_continents( HASH_REF );
-
-C<find_best_continents> goes through each continent and pings C<N>
-random mirrors on that continent. It then orders the continents by
-ascending median ping time. In list context, it returns the ordered list
-of continent. In scalar context, it returns the same list as an
-anonymous array.
-
-Arguments:
-
- n - the number of hosts to ping for each continent. Default: 3
- seen - a hashref of cached hostname ping times
- verbose - true or false for noisy or quiet. Default: false
- callback - a subroutine to run after each ping.
- ping_cache_limit - how long, in seconds, to reuse previous ping times.
- Default: 1 day
-
-The C<seen> hash has hostnames as keys and anonymous arrays as values.
-The anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a
-ping time, and the epoch time for the measurement.
-
-The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
-time, and measurement time (the same things in the C<seen> hashref) as
-arguments. C<find_best_continents> doesn't care what the callback does
-and ignores the return value.
-
-With a low value for C<N>, a single mirror might skew the results enough
-to choose a worse continent. If you have that problem, try a larger
-value.
-
-=cut
-
-sub find_best_continents {
- my ($self, %args) = @_;
+sub _find_best_continent {
+ my ($self, $seen, $verbose, $callback) = @_;
- $args{n} ||= 3;
- $args{verbose} = 0 unless defined $args{verbose};
- $args{seen} = {} unless defined $args{seen};
- croak "The seen argument must be a hash reference"
- unless ref $args{seen} eq ref {};
- $args{ping_cache_limit} = 24 * 60 * 60
- unless defined $args{ping_cache_time};
- croak "callback must be a subroutine"
- if( defined $args{callback} and ref $args{callback} ne ref sub {} );
-
- my %medians;
+ my %median;
CONT: for my $c ( $self->continents ) {
- print "Testing $c\n" if $args{verbose};
my @mirrors = $self->mirrors( $self->countries($c) );
-
next CONT unless @mirrors;
- my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
-
+ my $sample = 9;
+ my $n = (@mirrors < $sample) ? @mirrors : $sample;
my @tests;
- my $tries = 0;
- RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
+ RANDOM: while ( @mirrors && @tests < $n ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
- if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) {
- $self->get_mirrors_timings( [ $m ], @args{qw(seen callback)} );
- next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
- }
- printf "\t%s -> %0.2f ms\n",
- $m->hostname,
- join ' ', 1000 * $args{seen}{$m->hostname}->rtt
- if $args{verbose};
-
- push @tests, $args{seen}{$m->hostname}->rtt;
+ my $ping = $m->ping;
+ $callback->($m,$ping) if $callback;
+ # record undef so we don't try again
+ $seen->{$m->hostname} = [$m, $ping];
+ next RANDOM unless defined $ping;
+ push @tests, $ping;
+ }
+ next CONT unless @tests;
+ @tests = sort { $a <=> $b } @tests;
+ if ( @tests == 1 ) {
+ $median{$c} = $tests[0];
+ }
+ elsif ( @tests % 2 ) {
+ $median{$c} = $tests[ int(@tests / 2) ];
+ }
+ else {
+ my $mid_high = int(@tests/2);
+ $median{$c} = ($tests[$mid_high-1] + $tests[$mid_high])/2;
}
-
- my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
- $medians{$c} = $median if defined $median;
}
- my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
+ my @best_cont = sort { $median{$a} <=> $median{$b} } keys %median ;
- if ( $args{verbose} ) {
+ if ( $verbose ) {
print "Median result by continent:\n";
for my $c ( @best_cont ) {
- printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c );
+ printf( " %d ms %s\n", int($median{$c}*1000+.5), $c );
}
}
return wantarray ? @best_cont : $best_cont[0];
}
-# retry if
-sub _try_a_ping {
- my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
-
- ( ! exists $seen->{$mirror->hostname} )
- or
- (
- ! defined $seen->{$mirror->hostname}->rtt
- or
- time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit
- )
-}
-
-sub _get_median_ping_time {
- my ($self, $tests, $verbose ) = @_;
-
- my @sorted = sort { $a <=> $b } @$tests;
-
- my $median = do {
- if ( @sorted == 0 ) { undef }
- elsif ( @sorted == 1 ) { $sorted[0] }
- elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
- else {
- my $mid_high = int(@sorted/2);
- ($sorted[$mid_high-1] + $sorted[$mid_high])/2;
- }
- };
-
- printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose;
-
- return $median;
-}
-
# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
sub _parse {
my ($self, $file, $handle) = @_;
my $output = $self->{mirrors};
- my $geo = $self->{geography};
+ my $geo = $self->{geography};
local $/ = "\012";
my $line = 0;
@@ -480,7 +180,7 @@ sub _parse {
$mirror ||= {};
if ( $prop eq 'dst_location' ) {
my (@location,$continent,$country);
- @location = (split /\s*,\s*/, $value)
+ @location = (split /\s*,\s*/, $value)
and ($continent, $country) = @location[-1,-2];
$continent =~ s/\s\(.*//;
$continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
@@ -531,59 +231,30 @@ sub new {
$arg ||= {};
bless $arg, $self;
}
-sub hostname { shift->{hostname} }
-sub continent { shift->{continent} }
-sub country { shift->{country} }
-sub http { shift->{http} || '' }
-sub ftp { shift->{ftp} || '' }
-sub rsync { shift->{rsync} || '' }
-sub rtt { shift->{rtt} }
-sub ping_time { shift->{ping_time} }
-
-sub url {
+sub hostname { shift->{hostname} }
+sub continent { shift->{continent} }
+sub country { shift->{country} }
+sub http { shift->{http} || '' }
+sub ftp { shift->{ftp} || '' }
+sub rsync { shift->{rsync} || '' }
+
+sub url {
my $self = shift;
- return $self->{http} || $self->{ftp};
+ return $self->{ftp} || $self->{http};
}
sub ping {
my $self = shift;
-
- my $ping = Net::Ping->new($^O eq 'VMS' ? 'icmp' : 'tcp', 1);
+ my $ping = Net::Ping->new("tcp",1);
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
-
- if ( $ping->can('port_number') ) {
- $ping->port_number($port);
- }
- else {
- $ping->{'port_num'} = $port;
- }
-
- $ping->hires(1) if $ping->can('hires');
+ $ping->port_number($port);
+ $ping->hires(1);
my ($alive,$rtt) = $ping->ping($self->hostname);
-
- $self->{rtt} = $alive ? $rtt : undef;
- $self->{ping_time} = time;
-
- $self->rtt;
+ return $alive ? $rtt : undef;
}
1;
-=back
-
-=head1 AUTHOR
-
-Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
-brian d foy C<< <bdfoy@cpan.org> >>
-
-=head1 LICENSE
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Module.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Module.pm
index 2c0c71ae7d1..43c42bf1049 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Module.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Module.pm
@@ -7,7 +7,7 @@ use strict;
use vars qw(
$VERSION
);
-$VERSION = "5.5001";
+$VERSION = "5.5";
BEGIN {
# alarm() is not implemented in perl 5.6.x and earlier under Windows
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Nox.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Nox.pm
index f7ed4a38afb..5fe5a25ae6e 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Nox.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Nox.pm
@@ -6,11 +6,10 @@ BEGIN{
$CPAN::Suppress_readline=1 unless defined $CPAN::term;
}
-use Exporter ();
-@CPAN::ISA = ('Exporter');
+use base 'Exporter';
use CPAN;
-$VERSION = "5.5001";
+$VERSION = "5.50";
$CPAN::META->has_inst('Digest::MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm
index 8027d22d3b2..b60f57c1cfe 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm
@@ -20,11 +20,6 @@ sub reqtype {
$self->{reqtype};
}
-sub optional {
- my($self) = @_;
- $self->{optional};
-}
-
package CPAN::Queue;
# One use of the queue is to determine if we should or shouldn't
@@ -72,7 +67,7 @@ package CPAN::Queue;
# in CPAN::Distribution::rematein.
use vars qw{ @All $VERSION };
-$VERSION = "5.5002";
+$VERSION = "5.5";
# CPAN::Queue::queue_item ;
sub queue_item {
@@ -87,7 +82,7 @@ sub qpush {
my($class,$obj) = @_;
push @All, $obj;
CPAN->debug(sprintf("in new All[%s]",
- join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
+ join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All),
)) if $CPAN::DEBUG;
}
@@ -104,13 +99,9 @@ sub delete_first {
for my $i (0..$#All) {
if ( $All[$i]->{qmod} eq $what ) {
splice @All, $i, 1;
- last;
+ return;
}
}
- CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
- $what,
- join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
- )) if $CPAN::DEBUG;
}
# CPAN::Queue::jumpqueue ;
@@ -118,9 +109,9 @@ sub jumpqueue {
my $class = shift;
my @what = @_;
CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
- join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
- join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
- )) if $CPAN::DEBUG;
+ join("",
+ map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All, @what
+ ))) if $CPAN::DEBUG;
unless (defined $what[0]{reqtype}) {
# apparently it was not the Shell that sent us this enquiry,
# treat it as commandline
@@ -128,7 +119,7 @@ sub jumpqueue {
}
my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
WHAT: for my $what_tuple (@what) {
- my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
+ my($what,$reqtype) = @$what_tuple{qw(qmod reqtype)};
if ($reqtype eq "r"
&&
$inherit_reqtype eq "b"
@@ -137,23 +128,32 @@ sub jumpqueue {
}
my $jumped = 0;
for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
- if ($All[$i]{qmod} eq $qmod) {
+ # CPAN->debug("i[$i]this[$All[$i]{qmod}]what[$what]") if $CPAN::DEBUG;
+ if ($All[$i]{qmod} eq $what) {
$jumped++;
+ if ($jumped >= 50) {
+ die "PANIC: object[$what] 50 instances on the queue, looks like ".
+ "some recursiveness has hit";
+ } elsif ($jumped > 25) { # one's OK if e.g. just processing
+ # now; more are OK if user typed
+ # it several times
+ my $sleep = sprintf "%.1f", $jumped/10;
+ $CPAN::Frontend->mywarn(
+qq{Warning: Object [$what] queued $jumped times, sleeping $sleep secs!\n}
+ );
+ $CPAN::Frontend->mysleep($sleep);
+ # next WHAT;
+ }
}
}
- # high jumped values are normal for popular modules when
- # dealing with large bundles: XML::Simple,
- # namespace::autoclean, UNIVERSAL::require
- CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
my $obj = "$class\::Item"->new(
- qmod => $qmod,
- reqtype => $reqtype,
- optional => !! $optional,
+ qmod => $what,
+ reqtype => $reqtype
);
unshift @All, $obj;
}
CPAN->debug(sprintf("after jumpqueue All[%s]",
- join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
+ join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
)) if $CPAN::DEBUG;
}
@@ -172,7 +172,7 @@ sub delete {
@All = grep { $_->{qmod} ne $mod } @All;
CPAN->debug(sprintf("after delete mod[%s] All[%s]",
$mod,
- join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
+ join("",map {sprintf " %s\[%s]\n",$_->{qmod},$_->{reqtype}} @All)
)) if $CPAN::DEBUG;
}
@@ -186,35 +186,10 @@ sub size {
return scalar @All;
}
-sub reqtype_of {
- my($self,$mod) = @_;
- my $best = "";
- for my $item (grep { $_->{qmod} eq $mod } @All) {
- my $c = $item->{reqtype};
- if ($c eq "c") {
- $best = $c;
- last;
- } elsif ($c eq "r") {
- $best = $c;
- } elsif ($c eq "b") {
- if ($best eq "") {
- $best = $c;
- }
- } else {
- die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
- }
- }
- return $best;
-}
-
1;
__END__
-=head1 NAME
-
-CPAN::Queue - internal queue support for CPAN.pm
-
=head1 LICENSE
This program is free software; you can redistribute it and/or
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm
index 9e0bb14a2b8..91cbdd22ac8 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm
@@ -47,7 +47,7 @@ use vars qw(
"CPAN/Tarzip.pm",
"CPAN/Version.pm",
);
-$VERSION = "5.5004";
+$VERSION = "5.5001";
# record the initial timestamp for reload.
$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
@CPAN::Shell::ISA = qw(CPAN::Debug);
@@ -206,7 +206,7 @@ sub a {
sub globls {
my($self,$s,$pragmas) = @_;
# ls is really very different, but we had it once as an ordinary
- # command in the Shell (up to rev. 321) and we could not handle
+ # command in the Shell (upto rev. 321) and we could not handle
# force well then
my(@accept,@preexpand);
if ($s =~ /[\*\?\/]/) {
@@ -375,8 +375,16 @@ sub o {
$cfilter ||= "";
my $qrfilter = eval 'qr/$cfilter/';
my($k,$v);
- my $configpm = CPAN::HandleConfig->require_myconfig_or_config;
- $CPAN::Frontend->myprint("\$CPAN::Config options from $configpm\:\n");
+ $CPAN::Frontend->myprint("\$CPAN::Config options from ");
+ my @from;
+ if (exists $INC{'CPAN/Config.pm'}) {
+ push @from, $INC{'CPAN/Config.pm'};
+ }
+ if (exists $INC{'CPAN/MyConfig.pm'}) {
+ push @from, $INC{'CPAN/MyConfig.pm'};
+ }
+ $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
+ $CPAN::Frontend->myprint(":\n");
for $k (sort keys %CPAN::HandleConfig::can) {
next unless $k =~ /$qrfilter/;
$v = $CPAN::HandleConfig::can{$k};
@@ -604,7 +612,7 @@ sub _reload_this {
CPAN->debug("file[$file]") if $CPAN::DEBUG;
my @inc = @INC;
unless ($file && -f $file) {
- # this thingy is not in the INC path, maybe CPAN/MyConfig.pm?
+ # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
$file = $INC{$f};
unless (CPAN->has_inst("File::Basename")) {
@inc = File::Basename::dirname($file);
@@ -626,12 +634,9 @@ sub _reload_this {
if ($must_reload) {
my $fh = FileHandle->new($file) or
$CPAN::Frontend->mydie("Could not open $file: $!");
- my $content;
- {
- local($/);
- local $^W = 1;
- $content = <$fh>;
- }
+ local($/);
+ local $^W = 1;
+ my $content = <$fh>;
CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
if $CPAN::DEBUG;
delete $INC{$f};
@@ -650,21 +655,22 @@ sub _reload_this {
#-> sub CPAN::Shell::mkmyconfig ;
sub mkmyconfig {
- my($self) = @_;
- if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) {
- $CPAN::Frontend->myprint(
- "CPAN::MyConfig already exists as $configpm.\n" .
- "Running configuration again...\n"
- );
- require CPAN::FirstTime;
- CPAN::FirstTime::init($configpm);
- }
- else {
- # force some missing values to be filled in with defaults
- delete $CPAN::Config->{$_}
- for qw/build_dir cpan_home keep_source_where histfile/;
- CPAN::HandleConfig->load( make_myconfig => 1 );
- }
+ my($self, $cpanpm, %args) = @_;
+ require CPAN::FirstTime;
+ my $home = CPAN::HandleConfig::home();
+ $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
+ File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
+ File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
+ CPAN::HandleConfig::require_myconfig_or_config();
+ $CPAN::Config ||= {};
+ $CPAN::Config = {
+ %$CPAN::Config,
+ build_dir => undef,
+ cpan_home => undef,
+ keep_source_where => undef,
+ histfile => undef,
+ };
+ CPAN::FirstTime::init($cpanpm, %args);
}
#-> sub CPAN::Shell::_binary_extensions ;
@@ -772,201 +778,6 @@ sub scripts {
}
}
-sub _guess_manpage {
- my($self,$d,$contains,$dist) = @_;
- $dist =~ s/-/::/g;
- my $module;
- if (exists $contains->{$dist}) {
- $module = $dist;
- } elsif (1 == keys %$contains) {
- ($module) = keys %$contains;
- }
- my $manpage;
- if ($module) {
- my $m = $self->expand("Module",$module);
- $m->as_string; # called for side-effects, shame
- $manpage = $m->{MANPAGE};
- } else {
- $manpage = "unknown";
- }
- return $manpage;
-}
-
-#-> sub CPAN::Shell::_specfile ;
-sub _specfile {
- my $self = shift;
- my $distribution = shift;
- unless ($CPAN::META->has_inst("CPAN::DistnameInfo")){
- $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
- }
- my $d = CPAN::Shell->expand("Distribution",$distribution)
- or $CPAN::Frontend->mydie("Unknowns distribution '$distribution'\n");
- my $build_dir = $d->{build_dir} or $CPAN::Frontend->mydie("Distribution has not been built yet, cannot proceed");
- my %contains = map {($_ => undef)} $d->containsmods;
- my @m;
- my $width = 16;
- my $header = sub {
- my($header,$value) = @_;
- push @m, sprintf("%-s:%*s%s\n", $header, $width-length($header), "", $value);
- };
- my $dni = CPAN::DistnameInfo->new($distribution);
- my $dist = $dni->dist;
- my $summary = $self->_guess_manpage($d,\%contains,$dist);
- $header->("Name", "perl-$dist");
- my $version = $dni->version;
- $header->("Version", $version);
- $header->("Release", "1%{?dist}");
-#Summary: Template processing system
-#Group: Development/Libraries
-#License: GPL+ or Artistic
-#URL: http://www.template-toolkit.org/
-#Source0: http://search.cpan.org/CPAN/authors/id/A/AB/ABW/Template-Toolkit-%{version}.tar.gz
-#Patch0: Template-2.22-SREZIC-01.patch
-#BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
- for my $h_tuple
- ([Summary => $summary],
- [Group => "Development/Libraries"],
- [License =>],
- [URL =>],
- [BuildRoot => "%{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)"],
- [Requires => "perl(:MODULE_COMPAT_%(eval \"`%{__perl} -V:version`\"; echo \$version))"],
- ) {
- my($h,$v) = @$h_tuple;
- $v = "unknown" unless defined $v;
- $header->($h, $v);
- }
- $header->("Source0", sprintf(
- "http://search.cpan.org/CPAN/authors/id/%s/%s/%s",
- substr($distribution,0,1),
- substr($distribution,0,2),
- $distribution
- ));
- require POSIX;
- my @xs = glob "$build_dir/*.xs"; # quick try
- unless (@xs) {
- require ExtUtils::Manifest;
- my $manifest_file = "$build_dir/MANIFEST";
- my $manifest = ExtUtils::Manifest::maniread($manifest_file);
- @xs = grep /\.xs$/, keys %$manifest;
- }
- if (! @xs) {
- $header->('BuildArch', 'noarch');
- }
- for my $k (sort keys %contains) {
- my $m = CPAN::Shell->expand("Module",$k);
- my $v = $contains{$k} = $m->cpan_version;
- my $vspec = $v eq "undef" ? "" : " = $v";
- $header->("Provides", "perl($k)$vspec");
- }
- if (my $prereq_pm = $d->{prereq_pm}) {
- my %req;
- for my $reqkey (keys %$prereq_pm) {
- while (my($k,$v) = each %{$prereq_pm->{$reqkey}}) {
- $req{$k} = $v;
- }
- }
- if (-e "$build_dir/Build.PL" && ! exists $req{"Module::Build"}) {
- $req{"Module::Build"} = 0;
- }
- for my $k (sort keys %req) {
- next if $k eq "perl";
- my $v = $req{$k};
- my $vspec = defined $v && length $v && $v > 0 ? " >= $v" : "";
- $header->(BuildRequires => "perl($k)$vspec");
- next if $k =~ /^(Module::Build)$/; # MB is always only a
- # BuildRequires; if we
- # turn it into a
- # Requires, then we
- # would have to make it
- # a BuildRequires
- # everywhere we depend
- # on *one* MB built
- # module.
- $header->(Requires => "perl($k)$vspec");
- }
- }
- push @m, "\n%define _use_internal_dependency_generator 0
-%define __find_requires %{nil}
-%define __find_provides %{nil}
-";
- push @m, "\n%description\n%{summary}.\n";
- push @m, "\n%prep\n%setup -q -n $dist-%{version}\n";
- if (-e "$build_dir/Build.PL") {
- # see http://www.redhat.com/archives/rpm-list/2002-July/msg00110.html about RPM_BUILD_ROOT vs %{buildroot}
- push @m, <<'EOF';
-
-%build
-%{__perl} Build.PL --installdirs=vendor --libdoc installvendorman3dir
-./Build
-
-%install
-rm -rf $RPM_BUILD_ROOT
-./Build install destdir=$RPM_BUILD_ROOT create_packlist=0
-find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
-%{_fixperms} $RPM_BUILD_ROOT/*
-
-%check
-./Build test
-EOF
- } elsif (-e "$build_dir/Makefile.PL") {
- push @m, <<'EOF';
-
-%build
-%{__perl} Makefile.PL INSTALLDIRS=vendor
-make %{?_smp_mflags}
-
-%install
-rm -rf $RPM_BUILD_ROOT
-make pure_install DESTDIR=$RPM_BUILD_ROOT
-find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';'
-find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null ';'
-%{_fixperms} $RPM_BUILD_ROOT/*
-
-%check
-make test
-EOF
- } else {
- $CPAN::Frontend->mydie("'$distribution' has neither a Build.PL nor a Makefile.PL\n");
- }
- push @m, "\n%clean\nrm -rf \$RPM_BUILD_ROOT\n";
- my $vendorlib = @xs ? "vendorarch" : "vendorlib";
- my $date = POSIX::strftime("%a %b %d %Y", gmtime);
- my @doc = grep { -e "$build_dir/$_" } qw(README Changes);
- my $exe_stanza = "\n";
- if (my $exe_files = $d->_exe_files) {
- if (@$exe_files) {
- $exe_stanza = "%{_mandir}/man1/*.1*\n";
- for my $e (@$exe_files) {
- unless (CPAN->has_inst("File::Basename")) {
- $CPAN::Frontend->mydie("File::Basename not installed, cannot continue");
- }
- my $basename = File::Basename::basename($e);
- $exe_stanza .= "/usr/bin/$basename\n";
- }
- }
- }
- push @m, <<EOF;
-
-%files
-%defattr(-,root,root,-)
-%doc @doc
-%{perl_$vendorlib}/*
-%{_mandir}/man3/*.3*
-$exe_stanza
-%changelog
-* $date <akoenig\@specfile.cpan.org> - $version-1
-- autogenerated by _specfile() in CPAN.pm
-
-EOF
-
- my $ret = join "", @m;
- $CPAN::Frontend->myprint($ret);
- open my $specout, ">", "perl-$dist.spec" or die;
- print $specout $ret;
- $CPAN::Frontend->myprint("Wrote perl-$dist.spec");
- $ret;
-}
-
#-> sub CPAN::Shell::report ;
sub report {
my($self,@args) = @_;
@@ -1238,41 +1049,6 @@ sub u {
#-> sub CPAN::Shell::failed ;
sub failed {
my($self,$only_id,$silent) = @_;
- my @failed = $self->find_failed($only_id);
- my $scope;
- if ($only_id) {
- $scope = "this command";
- } elsif ($CPAN::Index::HAVE_REANIMATED) {
- $scope = "this or a previous session";
- # it might be nice to have a section for previous session and
- # a second for this
- } else {
- $scope = "this session";
- }
- if (@failed) {
- my $print;
- my $debug = 0;
- if ($debug) {
- $print = join "",
- map { sprintf "%5d %-45s: %s %s\n", @$_ }
- sort { $a->[0] <=> $b->[0] } @failed;
- } else {
- $print = join "",
- map { sprintf " %-45s: %s %s\n", @$_[1..3] }
- sort {
- $a->[0] <=> $b->[0]
- ||
- $a->[4] <=> $b->[4]
- } @failed;
- }
- $CPAN::Frontend->myprint("Failed during $scope:\n$print");
- } elsif (!$only_id || !$silent) {
- $CPAN::Frontend->myprint("Nothing failed in $scope\n");
- }
-}
-
-sub find_failed {
- my($self,$only_id) = @_;
my @failed;
DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
my $failed = "";
@@ -1305,10 +1081,6 @@ sub find_failed {
next DIST unless $failed;
my $id = $d->id;
$id =~ s|^./../||;
- ### XXX need to flag optional modules as '(optional)' if they are
- # from recommends/suggests -- i.e. *show* failure, but make it clear
- # it was failure of optional module -- xdg, 2012-04-01
- $id = "(optional) $id" if ! $d->{mandatory};
#$print .= sprintf(
# " %-45s: %s %s\n",
push @failed,
@@ -1320,7 +1092,6 @@ sub find_failed {
$failed,
$d->{$failed}->text,
$d->{$failed}{TIME}||0,
- !! $d->{mandatory},
] :
[
1,
@@ -1328,16 +1099,39 @@ sub find_failed {
$failed,
$d->{$failed},
0,
- !! $d->{mandatory},
]
);
}
- return @failed;
-}
-
-sub mandatory_dist_failed {
- my ($self) = @_;
- return grep { $_->[5] } $self->find_failed($CPAN::CurrentCommandID);
+ my $scope;
+ if ($only_id) {
+ $scope = "this command";
+ } elsif ($CPAN::Index::HAVE_REANIMATED) {
+ $scope = "this or a previous session";
+ # it might be nice to have a section for previous session and
+ # a second for this
+ } else {
+ $scope = "this session";
+ }
+ if (@failed) {
+ my $print;
+ my $debug = 0;
+ if ($debug) {
+ $print = join "",
+ map { sprintf "%5d %-45s: %s %s\n", @$_ }
+ sort { $a->[0] <=> $b->[0] } @failed;
+ } else {
+ $print = join "",
+ map { sprintf " %-45s: %s %s\n", @$_[1..3] }
+ sort {
+ $a->[0] <=> $b->[0]
+ ||
+ $a->[4] <=> $b->[4]
+ } @failed;
+ }
+ $CPAN::Frontend->myprint("Failed during $scope:\n$print");
+ } elsif (!$only_id || !$silent) {
+ $CPAN::Frontend->myprint("Nothing failed in $scope\n");
+ }
}
# XXX intentionally undocumented because completely bogus, unportable,
@@ -1436,7 +1230,6 @@ sub autobundle {
$fh->close;
$CPAN::Frontend->myprint("\nWrote bundle file
$to\n\n");
- return $to;
}
#-> sub CPAN::Shell::expandany ;
@@ -1643,14 +1436,6 @@ sub format_result {
my $print_ornamented_have_warned = 0;
sub colorize_output {
my $colorize_output = $CPAN::Config->{colorize_output};
- if ($colorize_output && $^O eq 'MSWin32' && !$CPAN::META->has_inst("Win32::Console::ANSI")) {
- unless ($print_ornamented_have_warned++) {
- # no myprint/mywarn within myprint/mywarn!
- warn "Colorize_output is set to true but Win32::Console::ANSI is not
-installed. To activate colorized output, please install Win32::Console::ANSI.\n\n";
- }
- $colorize_output = 0;
- }
if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
unless ($print_ornamented_have_warned++) {
# no myprint/mywarn within myprint/mywarn!
@@ -1671,7 +1456,6 @@ sub print_ornamented {
local $| = 1; # Flush immediately
if ( $CPAN::Be_Silent ) {
- # WARNING: variable Be_Silent is poisoned and must be eliminated.
print {report_fh()} $what;
return;
}
@@ -1684,7 +1468,7 @@ sub print_ornamented {
}
if ($self->colorize_output) {
if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
- # if you want to have this configurable, please file a bug report
+ # if you want to have this configurable, please file a bugreport
$ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
}
my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
@@ -1814,7 +1598,6 @@ sub unrecoverable_error {
#-> sub CPAN::Shell::mysleep ;
sub mysleep {
- return if $ENV{AUTOMATED_TESTING} || ! -t STDOUT;
my($self, $sleep) = @_;
if (CPAN->has_inst("Time::HiRes")) {
Time::HiRes::sleep($sleep);
@@ -1909,7 +1692,7 @@ sub rematein {
if ($meth =~ /^($needs_recursion_protection)$/) {
# it would be silly to check for recursion for look or dump
# (we are in CPAN::Shell::rematein)
- CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
+ CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
eval { $obj->color_cmd_tmps(0,1); };
if ($@) {
if (ref $@
@@ -1924,7 +1707,7 @@ sub rematein {
}
}
}
- CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c", optional => '');
+ CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c");
push @qcopy, $obj;
} elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
$obj = $CPAN::META->instance('CPAN::Author',uc($s));
@@ -1962,7 +1745,6 @@ to find objects with matching identifiers.
my $obj;
my $s = $q->as_string;
my $reqtype = $q->reqtype || "";
- my $optional = $q->optional || "";
$obj = CPAN::Shell->expandany($s);
unless ($obj) {
# don't know how this can happen, maybe we should panic,
@@ -1975,23 +1757,6 @@ to find objects with matching identifiers.
next QITEM;
}
$obj->{reqtype} ||= "";
- my $type = ref $obj;
- if ( $type eq 'CPAN::Distribution' || $type eq 'CPAN::Bundle' ) {
- $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
- }
- elsif ( $type eq 'CPAN::Module' ) {
- $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
- if (my $d = $obj->distribution) {
- $d->{mandatory} ||= ! $optional; # once mandatory, always mandatory
- } elsif ($optional) {
- # the queue object does not know who was recommending/suggesting us:(
- # So we only vaguely write "optional".
- $CPAN::Frontend->mywarn("Warning: optional module '$s' ".
- "not known. Skipping.\n");
- CPAN::Queue->delete_first($s);
- next QITEM;
- }
- }
{
# force debugging because CPAN::SQLite somehow delivers us
# an empty object;
@@ -2054,18 +1819,11 @@ to find objects with matching identifiers.
}
CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
$CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
+ } elsif ($obj->$meth()) {
+ CPAN::Queue->delete($s);
+ CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
} else {
- my $upgraded_meth = $meth;
- if ( $meth eq "make" and $obj->{reqtype} eq "b" ) {
- # rt 86915
- $upgraded_meth = "test";
- }
- if ($obj->$upgraded_meth()) {
- CPAN::Queue->delete($s);
- CPAN->debug("Succeeded and deleted from queue. pragma[@pragma]meth[$meth][s][$s]") if $CPAN::DEBUG;
- } else {
- CPAN->debug("Failed. pragma[@pragma]meth[$meth]s[$s]") if $CPAN::DEBUG;
- }
+ CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
}
$obj->undelay;
@@ -2075,14 +1833,10 @@ to find objects with matching identifiers.
$obj->$unpragma();
}
}
- # if any failures occurred and the current object is mandatory, we
- # still don't know if *it* failed or if it was another (optional)
- # module, so we have to check that explicitly (and expensively)
- if ( $CPAN::Config->{halt_on_failure}
- && $obj->{mandatory}
- && CPAN::Distrostatus::something_has_just_failed()
- && $self->mandatory_dist_failed()
- ) {
+ if ($CPAN::Config->{halt_on_failure}
+ &&
+ CPAN::Distrostatus::something_has_just_failed()
+ ) {
$CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
CPAN::Queue->nullify_queue;
last QITEM;
@@ -2101,7 +1855,7 @@ sub recent {
my($self) = @_;
if ($CPAN::META->has_inst("XML::LibXML")) {
my $url = $CPAN::Defaultrecent;
- $CPAN::Frontend->myprint("Fetching '$url'\n");
+ $CPAN::Frontend->myprint("Going to fetch '$url'\n");
unless ($CPAN::META->has_usable("LWP")) {
$CPAN::Frontend->mydie("LWP not installed; cannot continue");
}
@@ -2189,7 +1943,7 @@ sub smoke {
my $distros = $self->recent;
DISTRO: for my $distro (@$distros) {
next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
- $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
+ $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n");
{
my $skip = 0;
local $SIG{INT} = sub { $skip = 1 };
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm
index f585a01bf72..63451e7450d 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw($VERSION @ISA $BUGHUNTING);
use CPAN::Debug;
use File::Basename qw(basename);
-$VERSION = "5.5012";
+$VERSION = "5.5011";
# module is internal to CPAN.pm
@ISA = qw(CPAN::Debug); ## no critic
@@ -73,7 +73,6 @@ sub gzip {
my $cwd = `pwd`;
my $gz = Compress::Zlib::gzopen($write, "wb")
or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
- binmode($fhw);
$gz->gzwrite($buffer)
while read($fhw,$buffer,4096) > 0 ;
$gz->gzclose() ;
@@ -95,9 +94,8 @@ sub gunzip {
or $CPAN::Frontend->mydie("Could not open >$write: $!");
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
- binmode($fhw);
$fhw->print($buffer)
- while $gz->gzread($buffer) > 0 ;
+ while $gz->gzread($buffer) > 0 ;
$CPAN::Frontend->mydie("Error reading from $read: $!\n")
if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
$gz->gzclose() ;
@@ -105,7 +103,7 @@ sub gunzip {
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
- system(qq{$command -d -c "$read" > "$write"})==0;
+ system(qq{$command -dc "$read" > "$write"})==0;
}
}
@@ -190,7 +188,7 @@ sub TIEHANDLE {
$class->debug("via Compress::Zlib");
} else {
my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
- my $pipe = "$gzip -d -c $file |";
+ my $pipe = "$gzip -dc $file |";
my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
binmode $fh;
$self->{FH} = $fh;
@@ -255,21 +253,14 @@ sub untar {
if (0) { # makes changing order easier
} elsif ($BUGHUNTING) {
$prefer=2;
- } elsif ($CPAN::Config->{prefer_external_tar}) {
+ } elsif ($exttar && $extgzip && $file =~ /\.(?:bz2|tbz)$/i) {
+ # until Archive::Tar handles bzip2
$prefer = 1;
} elsif (
$CPAN::META->has_usable("Archive::Tar")
&&
$CPAN::META->has_inst("Compress::Zlib") ) {
- my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
- unless (defined $prefer_external_tar) {
- if ($^O =~ /(MSWin32|solaris)/) {
- $prefer_external_tar = 0;
- } else {
- $prefer_external_tar = 1;
- }
- }
- $prefer = $prefer_external_tar ? 1 : 2;
+ $prefer = 2;
} elsif ($exttar && $extgzip) {
# no modules and not bz2
$prefer = 1;
@@ -324,7 +315,7 @@ Can't continue cutting file '$file'.
my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
if ($is_compressed) {
my $command = CPAN::HandleConfig->safe_quote($extgzip);
- $system = qq{$command -d -c }.
+ $system = qq{$command -dc }.
qq{< "$file" | $tarcommand x${tar_verb}f -};
} else {
$system = qq{$tarcommand x${tar_verb}f "$file"};
@@ -345,20 +336,10 @@ Can't continue cutting file '$file'.
}
$system = qq{$tarcommand x${tar_verb}f "$file"};
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
- my $ret = system($system);
- if ($ret==0) {
+ if (system($system)==0) {
$CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
} else {
- if ($? == -1) {
- $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
- $file, $!);
- } elsif ($? & 127) {
- $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
- $file, ($? & 127), ($? & 128) ? 'with' : 'without');
- } else {
- $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
- $file, $? >> 8);
- }
+ $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
}
return 1;
} else {
@@ -462,10 +443,6 @@ END
__END__
-=head1 NAME
-
-CPAN::Tarzip - internal handling of tar archives for CPAN.pm
-
=head1 LICENSE
This program is free software; you can redistribute it and/or
diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Version.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Version.pm
index fa75221d9da..da876aac2d7 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Version.pm
+++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Version.pm
@@ -2,7 +2,7 @@ package CPAN::Version;
use strict;
use vars qw($VERSION);
-$VERSION = "5.5003";
+$VERSION = "5.5";
# CPAN::Version::vcmp courtesy Jost Krieger
sub vcmp {
@@ -10,10 +10,6 @@ sub vcmp {
local($^W) = 0;
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
- # treat undef as zero
- $l = 0 if $l eq 'undef';
- $r = 0 if $r eq 'undef';
-
return 0 if $l eq $r; # short circuit for quicker success
for ($l,$r) {
@@ -61,7 +57,7 @@ sub vgt {
sub vlt {
my($self,$l,$r) = @_;
- $self->vcmp($l,$r) < 0;
+ 0 + ($self->vcmp($l,$r) < 0);
}
sub vge {
@@ -71,7 +67,7 @@ sub vge {
sub vle {
my($self,$l,$r) = @_;
- $self->vcmp($l,$r) <= 0;
+ 0 + ($self->vcmp($l,$r) <= 0);
}
sub vstring {
diff --git a/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan b/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan
index 3b4a5b5067b..5e5609555f6 100644
--- a/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan
+++ b/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan
@@ -1,10 +1,9 @@
#!/usr/local/bin/perl
-
use strict;
use vars qw($VERSION);
-use App::Cpan '1.60_02';
-$VERSION = '1.61';
+use App::Cpan;
+$VERSION = '1.57';
my $rc = App::Cpan->run( @ARGV );
@@ -21,7 +20,7 @@ cpan - easily interact with CPAN from the command line
cpan module_name [ module_name ... ]
# with switches, installs modules with extra behavior
- cpan [-cfgimtTw] module_name [ module_name ... ]
+ cpan [-cfgimt] module_name [ module_name ... ]
# with just the dot, install from the distribution in the
# current directory
@@ -67,7 +66,10 @@ Show the F<Changes> files for the specified modules
=item -D module [ module ... ]
-Show the module details.
+Show the module details. This prints one line for each out-of-date module
+(meaning, modules locally installed but have newer versions on CPAN).
+Each line has three columns: module name, local version, and CPAN
+version.
=item -f
@@ -108,10 +110,6 @@ of the other options and arguments.
Install the specified modules.
-=item -I
-
-Load C<local::lib> (think like C<-I> for loading lib paths).
-
=item -j Config.pm
Load the file that has the CPAN configuration data. This should have the
@@ -124,10 +122,6 @@ Dump the configuration in the same format that CPAN.pm uses. This is useful
for checking the configuration as well as using the dump as a starting point
for a new, custom configuration.
-=item -l
-
-List all installed modules with their versions
-
=item -L author [ author ... ]
List the modules by the specified authors.
@@ -140,46 +134,18 @@ Make the specified modules.
Show the out-of-date modules.
-=item -p
-
-Ping the configured mirrors
-
-=item -P
-
-Find the best mirrors you could be using (but doesn't configure them just yet)
-
-=item -r
-
-Recompiles dynamically loaded modules with CPAN::Shell->recompile.
-
=item -t
Run a `make test` on the specified modules.
-=item -T
-
-Do not test modules. Simply install them.
-
-=item -u
+=item -r
-Upgrade all installed modules. Blindly doing this can really break things,
-so keep a backup.
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
=item -v
Print the script version and CPAN.pm version then exit.
-=item -V
-
-Print detailed information about the cpan client.
-
-=item -w
-
-UNIMPLEMENTED
-
-Turn on cpan warnings. This checks various things, like directory permissions,
-and tells you about problems you might have.
-
=back
=head2 Examples
@@ -196,27 +162,12 @@ and tells you about problems you might have.
# recompile modules
cpan -r
- # upgrade all installed modules
- cpan -u
-
# install modules ( sole -i is optional )
cpan -i Netscape::Booksmarks Business::ISBN
# force install modules ( must use -i )
cpan -fi CGI::Minimal URI
-=head1 ENVIRONMENT VARIABLES
-
-=over 4
-
-=item CPAN_OPTS
-
-C<cpan> splits this variable on whitespace and prepends that list to C<@ARGV>
-before it processes the command-line arguments. For instance, if you always
-want to use C<local:lib>, you can set C<CPAN_OPTS> to C<-I>.
-
-=back
-
=head1 EXIT VALUES
The script exits with zero if it thinks that everything worked, or a
@@ -236,6 +187,8 @@ not control. For now, the exit codes are vague:
* one shot configuration values from the command line
+
+
=head1 BUGS
* none noted
@@ -267,7 +220,7 @@ brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT
-Copyright (c) 2001-2013, brian d foy, All Rights Reserved.
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/Digest-SHA/lib/Digest/SHA.pm b/gnu/usr.bin/perl/cpan/Digest-SHA/lib/Digest/SHA.pm
index 57f0bd6ef6f..d57c16fce59 100644
--- a/gnu/usr.bin/perl/cpan/Digest-SHA/lib/Digest/SHA.pm
+++ b/gnu/usr.bin/perl/cpan/Digest-SHA/lib/Digest/SHA.pm
@@ -3,11 +3,10 @@ package Digest::SHA;
require 5.003000;
use strict;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-use Fcntl;
use integer;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = '5.88';
+$VERSION = '5.47';
require Exporter;
require DynaLoader;
@@ -18,26 +17,25 @@ require DynaLoader;
hmac_sha256 hmac_sha256_base64 hmac_sha256_hex
hmac_sha384 hmac_sha384_base64 hmac_sha384_hex
hmac_sha512 hmac_sha512_base64 hmac_sha512_hex
- hmac_sha512224 hmac_sha512224_base64 hmac_sha512224_hex
- hmac_sha512256 hmac_sha512256_base64 hmac_sha512256_hex
sha1 sha1_base64 sha1_hex
sha224 sha224_base64 sha224_hex
sha256 sha256_base64 sha256_hex
sha384 sha384_base64 sha384_hex
- sha512 sha512_base64 sha512_hex
- sha512224 sha512224_base64 sha512224_hex
- sha512256 sha512256_base64 sha512256_hex);
+ sha512 sha512_base64 sha512_hex);
+
+# If possible, inherit from Digest::base (which depends on MIME::Base64)
-# If possible, inherit from Digest::base
+*addfile = \&Addfile;
eval {
+ require MIME::Base64;
require Digest::base;
push(@ISA, 'Digest::base');
};
-
-*addfile = \&Addfile;
-*hexdigest = \&Hexdigest;
-*b64digest = \&B64digest;
+if ($@) {
+ *hexdigest = \&Hexdigest;
+ *b64digest = \&B64digest;
+}
# The following routines aren't time-critical, so they can be left in Perl
@@ -49,8 +47,8 @@ sub new {
sharewind($$class);
return($class);
}
- if ($$class) { shaclose($$class); $$class = undef }
- return unless $$class = shaopen($alg);
+ shaclose($$class) if $$class;
+ $$class = shaopen($alg) || return;
return($class);
}
$alg = 1 unless defined $alg;
@@ -62,7 +60,7 @@ sub new {
sub DESTROY {
my $self = shift;
- if ($$self) { shaclose($$self); $$self = undef }
+ shaclose($$self) if $$self;
}
sub clone {
@@ -81,7 +79,6 @@ sub add_bits {
$nbits = length($data);
$data = pack("B*", $data);
}
- $nbits = length($data) * 8 if $nbits > length($data) * 8;
shawrite($data, $nbits, $$self);
return($self);
}
@@ -89,9 +86,8 @@ sub add_bits {
sub _bail {
my $msg = shift;
- $msg .= ": $!";
require Carp;
- Carp::croak($msg);
+ Carp::croak("$msg: $!");
}
sub _addfile { # this is "addfile" from Digest::base 1.00
@@ -108,166 +104,68 @@ sub _addfile { # this is "addfile" from Digest::base 1.00
$self;
}
-my $_can_T_filehandle;
-
-sub _istext {
- local *FH = shift;
- my $file = shift;
-
- if (! defined $_can_T_filehandle) {
- local $^W = 0;
- eval { -T FH };
- $_can_T_filehandle = $@ ? 0 : 1;
- }
- return $_can_T_filehandle ? -T FH : -T $file;
-}
-
sub Addfile {
my ($self, $file, $mode) = @_;
return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
$mode = defined($mode) ? $mode : "";
- my ($binary, $portable, $BITS) = map { $_ eq $mode } ("b", "p", "0");
+ my ($binary, $portable) = map { $_ eq $mode } ("b", "p");
+ my $text = -T $file;
- ## Always interpret "-" to mean STDIN; otherwise use
- ## sysopen to handle full range of POSIX file names
local *FH;
- $file eq '-' and open(FH, '< -')
- or sysopen(FH, $file, O_RDONLY)
- or _bail('Open failed');
-
- if ($BITS) {
- my ($n, $buf) = (0, "");
- while (($n = read(FH, $buf, 4096))) {
- $buf =~ s/[^01]//g;
- $self->add_bits($buf);
- }
- _bail("Read failed") unless defined $n;
- close(FH);
- return($self);
- }
-
+ # protect any leading or trailing whitespace in $file;
+ # otherwise, 2-arg "open" will ignore them
+ $file =~ s#^(\s)#./$1#;
+ open(FH, "< $file\0") or _bail("Open failed");
binmode(FH) if $binary || $portable;
- unless ($portable && _istext(*FH, $file)) {
+
+ unless ($portable && $text) {
$self->_addfile(*FH);
close(FH);
return($self);
}
- while (<FH>) {
- s/\015?\015\012/\012/g; # DOS/Windows
- s/\015/\012/g; # early MacOS
- $self->add($_);
- }
- close(FH);
-
- $self;
-}
-
-sub getstate {
- my $self = shift;
-
- my $alg = $self->algorithm or return;
- my $state = $self->_getstate or return;
- my $nD = $alg <= 256 ? 8 : 16;
- my $nH = $alg <= 256 ? 32 : 64;
- my $nB = $alg <= 256 ? 64 : 128;
- my($H, $block, $blockcnt, $lenhh, $lenhl, $lenlh, $lenll) =
- $state =~ /^(.{$nH})(.{$nB})(.{4})(.{4})(.{4})(.{4})(.{4})$/s;
- for ($alg, $H, $block, $blockcnt, $lenhh, $lenhl, $lenlh, $lenll) {
- return unless defined $_;
- }
-
- my @s = ();
- push(@s, "alg:" . $alg);
- push(@s, "H:" . join(":", unpack("H*", $H) =~ /.{$nD}/g));
- push(@s, "block:" . join(":", unpack("H*", $block) =~ /.{2}/g));
- push(@s, "blockcnt:" . unpack("N", $blockcnt));
- push(@s, "lenhh:" . unpack("N", $lenhh));
- push(@s, "lenhl:" . unpack("N", $lenhl));
- push(@s, "lenlh:" . unpack("N", $lenlh));
- push(@s, "lenll:" . unpack("N", $lenll));
- join("\n", @s) . "\n";
-}
+ my ($n1, $n2);
+ my ($buf1, $buf2) = ("", "");
-sub putstate {
- my $class = shift;
- my $state = shift;
-
- my %s = ();
- for (split(/\n/, $state)) {
- s/^\s+//;
- s/\s+$//;
- next if (/^(#|$)/);
- my @f = split(/[:\s]+/);
- my $tag = shift(@f);
- $s{$tag} = join('', @f);
- }
-
- # H and block may contain arbitrary values, but check everything else
- grep { $_ == $s{'alg'} } (1,224,256,384,512,512224,512256) or return;
- length($s{'H'}) == ($s{'alg'} <= 256 ? 64 : 128) or return;
- length($s{'block'}) == ($s{'alg'} <= 256 ? 128 : 256) or return;
- {
- no integer;
- for (qw(blockcnt lenhh lenhl lenlh lenll)) {
- 0 <= $s{$_} or return;
- $s{$_} <= 4294967295 or return;
+ while (($n1 = read(FH, $buf1, 4096))) {
+ while (substr($buf1, -1) eq "\015") {
+ $n2 = read(FH, $buf2, 4096);
+ _bail("Read failed") unless defined $n2;
+ last unless $n2;
+ $buf1 .= $buf2;
}
- $s{'blockcnt'} < ($s{'alg'} <= 256 ? 512 : 1024) or return;
+ $buf1 =~ s/\015?\015\012/\012/g; # DOS/Windows
+ $buf1 =~ s/\015/\012/g; # early MacOS
+ $self->add($buf1);
}
+ _bail("Read failed") unless defined $n1;
+ close(FH);
- my $state_packed = (
- pack("H*", $s{'H'}) .
- pack("H*", $s{'block'}) .
- pack("N", $s{'blockcnt'}) .
- pack("N", $s{'lenhh'}) .
- pack("N", $s{'lenhl'}) .
- pack("N", $s{'lenlh'}) .
- pack("N", $s{'lenll'})
- );
-
- if (ref($class)) { # instance method
- if ($$class) { shaclose($$class); $$class = undef }
- return unless $$class = shaopen($s{'alg'});
- return $class->_putstate($state_packed);
- }
- else {
- my $sha = shaopen($s{'alg'}) or return;
- my $self = \$sha;
- bless($self, $class);
- return $self->_putstate($state_packed);
- }
+ $self;
}
sub dump {
my $self = shift;
- my $file = shift;
-
- my $state = $self->getstate or return;
- $file = "-" if (!defined($file) || $file eq "");
-
- local *FH;
- open(FH, "> $file") or return;
- print FH $state;
- close(FH);
+ my $file = shift || "";
+ shadump($file, $$self) || return;
return($self);
}
sub load {
my $class = shift;
- my $file = shift;
-
- $file = "-" if (!defined($file) || $file eq "");
-
- local *FH;
- open(FH, "< $file") or return;
- my $str = join('', <FH>);
- close(FH);
-
- $class->putstate($str);
+ my $file = shift || "";
+ if (ref($class)) { # instance method
+ shaclose($$class) if $$class;
+ $$class = shaload($file) || return;
+ return($class);
+ }
+ my $state = shaload($file) || return;
+ my $self = \$state;
+ bless($self, $class);
+ return($self);
}
Digest::SHA->bootstrap($VERSION);
@@ -309,9 +207,9 @@ In programs:
$sha->add_bits($bits);
$sha->add_bits($data, $nbits);
- $sha_copy = $sha->clone; # make copy of digest object
- $state = $sha->getstate; # save current state to string
- $sha->putstate($state); # restore previous $state
+ $sha_copy = $sha->clone; # if needed, make copy of
+ $sha->dump($file); # current digest state,
+ $sha->load($file); # or save it on disk
$digest = $sha->digest; # compute digest
$digest = $sha->hexdigest;
@@ -335,10 +233,11 @@ From the command line:
=head1 ABSTRACT
-Digest::SHA is a complete implementation of the NIST Secure Hash Standard.
-It gives Perl programmers a convenient way to calculate SHA-1, SHA-224,
-SHA-256, SHA-384, SHA-512, SHA-512/224, and SHA-512/256 message digests.
-The module can handle all types of input, including partial-byte data.
+Digest::SHA is a complete implementation of the NIST Secure Hash
+Standard. It gives Perl programmers a convenient way to calculate
+SHA-1, SHA-224, SHA-256, SHA-384, and SHA-512 message digests.
+The module can handle all types of input, including partial-byte
+data.
=head1 DESCRIPTION
@@ -386,15 +285,16 @@ Note that for larger bit-strings, it's more efficient to use the
two-argument version I<add_bits($data, $nbits)>, where I<$data> is
in the customary packed binary format used for Perl strings.
-The module also lets you save intermediate SHA states to a string. The
-I<getstate()> method generates portable, human-readable text describing
-the current state of computation. You can subsequently restore that
-state with I<putstate()> to resume where the calculation left off.
+The module also lets you save intermediate SHA states to disk, or
+display them on standard output. The I<dump()> method generates
+portable, human-readable text describing the current state of
+computation. You can subsequently retrieve the file with I<load()>
+to resume where the calculation left off.
To see what a state description looks like, just run the following:
use Digest::SHA;
- print Digest::SHA->new->add("Shaw" x 1962)->getstate;
+ Digest::SHA->new->add("Shaw" x 1962)->dump;
As an added convenience, the Digest::SHA module offers routines to
calculate keyed hashes using the HMAC-SHA-1/224/256/384/512
@@ -407,44 +307,21 @@ I<sha_base64()> functions.
use Digest::SHA qw(hmac_sha256_hex);
print hmac_sha256_hex("Hi There", chr(0x0b) x 32), "\n";
-=head1 UNICODE AND SIDE EFFECTS
-
-Perl supports Unicode strings as of version 5.6. Such strings may
-contain wide characters, namely, characters whose ordinal values are
-greater than 255. This can cause problems for digest algorithms such
-as SHA that are specified to operate on sequences of bytes.
-
-The rule by which Digest::SHA handles a Unicode string is easy
-to state, but potentially confusing to grasp: the string is interpreted
-as a sequence of byte values, where each byte value is equal to the
-ordinal value (viz. code point) of its corresponding Unicode character.
-That way, the Unicode string 'abc' has exactly the same digest value as
-the ordinary string 'abc'.
-
-Since a wide character does not fit into a byte, the Digest::SHA
-routines croak if they encounter one. Whereas if a Unicode string
-contains no wide characters, the module accepts it quite happily.
-The following code illustrates the two cases:
-
- $str1 = pack('U*', (0..255));
- print sha1_hex($str1); # ok
-
- $str2 = pack('U*', (0..256));
- print sha1_hex($str2); # croaks
-
-Be aware that the digest routines silently convert UTF-8 input into its
-equivalent byte sequence in the native encoding (cf. utf8::downgrade).
-This side effect influences only the way Perl stores the data internally,
-but otherwise leaves the actual value of the data intact.
-
=head1 NIST STATEMENT ON SHA-1
-NIST acknowledges that the work of Prof. Xiaoyun Wang constitutes a
-practical collision attack on SHA-1. Therefore, NIST encourages the
-rapid adoption of the SHA-2 hash functions (e.g. SHA-256) for applications
-requiring strong collision resistance, such as digital signatures.
+I<NIST was recently informed that researchers had discovered a way
+to "break" the current Federal Information Processing Standard SHA-1
+algorithm, which has been in effect since 1994. The researchers
+have not yet published their complete results, so NIST has not
+confirmed these findings. However, the researchers are a reputable
+research team with expertise in this area.>
+
+I<Due to advances in computing power, NIST already planned to phase
+out SHA-1 in favor of the larger and stronger hash functions (SHA-224,
+SHA-256, SHA-384 and SHA-512) by 2010. New developments should use
+the larger and stronger hash functions.>
-ref. L<http://csrc.nist.gov/groups/ST/hash/statement.html>
+ref. L<http://www.csrc.nist.gov/pki/HashWorkshop/NIST%20Statement/Burr_Mar2005.html>
=head1 PADDING OF BASE64 DIGESTS
@@ -495,10 +372,6 @@ I<Functional style>
=item B<sha512($data, ...)>
-=item B<sha512224($data, ...)>
-
-=item B<sha512256($data, ...)>
-
Logically joins the arguments into a single string, and returns
its SHA-1/224/256/384/512 digest encoded as a binary string.
@@ -512,10 +385,6 @@ its SHA-1/224/256/384/512 digest encoded as a binary string.
=item B<sha512_hex($data, ...)>
-=item B<sha512224_hex($data, ...)>
-
-=item B<sha512256_hex($data, ...)>
-
Logically joins the arguments into a single string, and returns
its SHA-1/224/256/384/512 digest encoded as a hexadecimal string.
@@ -529,10 +398,6 @@ its SHA-1/224/256/384/512 digest encoded as a hexadecimal string.
=item B<sha512_base64($data, ...)>
-=item B<sha512224_base64($data, ...)>
-
-=item B<sha512256_base64($data, ...)>
-
Logically joins the arguments into a single string, and returns
its SHA-1/224/256/384/512 digest encoded as a Base64 string.
@@ -549,11 +414,10 @@ I<OOP style>
=item B<new($alg)>
-Returns a new Digest::SHA object. Allowed values for I<$alg> are 1,
-224, 256, 384, 512, 512224, or 512256. It's also possible to use
-common string representations of the algorithm (e.g. "sha256",
-"SHA-384"). If the argument is missing, SHA-1 will be used by
-default.
+Returns a new Digest::SHA object. Allowed values for I<$alg> are
+1, 224, 256, 384, or 512. It's also possible to use common string
+representations of the algorithm (e.g. "sha256", "SHA-384"). If
+the argument is missing, SHA-1 will be used by default.
Invoking I<new> as an instance method will not create a new object;
instead, it will simply reset the object to the initial state
@@ -568,14 +432,14 @@ I<reset> is just an alias for I<new>.
=item B<hashsize>
Returns the number of digest bits for this object. The values are
-160, 224, 256, 384, 512, 224, and 256 for SHA-1, SHA-224, SHA-256,
-SHA-384, SHA-512, SHA-512/224 and SHA-512/256, respectively.
+160, 224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384,
+and SHA-512, respectively.
=item B<algorithm>
Returns the digest algorithm for this object. The values are 1,
-224, 256, 384, 512, 512224, and 512256 for SHA-1, SHA-224, SHA-256,
-SHA-384, SHA-512, SHA-512/224, and SHA-512/256, respectively.
+224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384, and
+SHA-512, respectively.
=item B<clone>
@@ -633,45 +497,31 @@ argument to one of the following values:
"p" use portable mode
- "0" use BITS mode
-
-The "p" mode ensures that the digest value of I<$filename> will be the
-same when computed on different operating systems. It accomplishes
-this by internally translating all newlines in text files to UNIX format
-before calculating the digest. Binary files are read in raw mode with
-no translation whatsoever.
-
-The BITS mode ("0") interprets the contents of I<$filename> as a logical
-stream of bits, where each ASCII '0' or '1' character represents a 0 or
-1 bit, respectively. All other characters are ignored. This provides
-a convenient way to calculate the digest values of partial-byte data by
-using files, rather than having to write programs using the I<add_bits>
-method.
+The "p" mode is handy since it ensures that the digest value of
+I<$filename> will be the same when computed on different operating
+systems. It accomplishes this by internally translating all newlines in
+text files to UNIX format before calculating the digest. Binary files
+are read in raw mode with no translation whatsoever.
-=item B<getstate>
-
-Returns a string containing a portable, human-readable representation
-of the current SHA state.
-
-=item B<putstate($str)>
-
-Returns a Digest::SHA object representing the SHA state contained
-in I<$str>. The format of I<$str> matches the format of the output
-produced by method I<getstate>. If called as a class method, a new
-object is created; if called as an instance method, the object is reset
-to the state contained in I<$str>.
+For a fuller discussion of newline formats, refer to CPAN module
+L<File::LocalizeNewlines>. Its "universal line separator" regex forms
+the basis of I<addfile>'s portable mode processing.
=item B<dump($filename)>
-Writes the output of I<getstate> to I<$filename>. If the argument is
-missing, or equal to the empty string, the state information will be
-written to STDOUT.
+Provides persistent storage of intermediate SHA states by writing
+a portable, human-readable representation of the current state to
+I<$filename>. If the argument is missing, or equal to the empty
+string, the state information will be written to STDOUT.
=item B<load($filename)>
-Returns a Digest::SHA object that results from calling I<putstate> on
-the contents of I<$filename>. If the argument is missing, or equal to
-the empty string, the state information will be read from STDIN.
+Returns a Digest::SHA object representing the intermediate SHA
+state that was previously dumped to I<$filename>. If called as a
+class method, a new object is created; if called as an instance
+method, the object is reset to the state contained in I<$filename>.
+If the argument is missing, or equal to the empty string, the state
+information will be read from STDIN.
=item B<digest>
@@ -726,10 +576,6 @@ I<HMAC-SHA-1/224/256/384/512>
=item B<hmac_sha512($data, $key)>
-=item B<hmac_sha512224($data, $key)>
-
-=item B<hmac_sha512256($data, $key)>
-
Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
with the result encoded as a binary string. Multiple I<$data>
arguments are allowed, provided that I<$key> is the last argument
@@ -745,10 +591,6 @@ in the list.
=item B<hmac_sha512_hex($data, $key)>
-=item B<hmac_sha512224_hex($data, $key)>
-
-=item B<hmac_sha512256_hex($data, $key)>
-
Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
with the result encoded as a hexadecimal string. Multiple I<$data>
arguments are allowed, provided that I<$key> is the last argument
@@ -764,10 +606,6 @@ in the list.
=item B<hmac_sha512_base64($data, $key)>
-=item B<hmac_sha512224_base64($data, $key)>
-
-=item B<hmac_sha512256_base64($data, $key)>
-
Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
with the result encoded as a Base64 string. Multiple I<$data>
arguments are allowed, provided that I<$key> is the last argument
@@ -784,9 +622,9 @@ CPAN Digest modules. See L</"PADDING OF BASE64 DIGESTS"> for details.
L<Digest>, L<Digest::SHA::PurePerl>
-The Secure Hash Standard (Draft FIPS PUB 180-4) can be found at:
+The Secure Hash Standard (FIPS PUB 180-2) can be found at:
-L<http://csrc.nist.gov/publications/drafts/fips180-4/Draft-FIPS180-4_Feb2011.pdf>
+L<http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>
The Keyed-Hash Message Authentication Code (HMAC):
@@ -801,11 +639,9 @@ L<http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>
The author is particularly grateful to
Gisle Aas
- Sean Burke
Chris Carey
Alexandr Ciornii
Jim Doble
- Thomas Drugeon
Julius Duque
Jeffrey Friedl
Robert Gilmour
@@ -819,13 +655,11 @@ The author is particularly grateful to
Gunnar Wolf
Adam Woodbury
-"who by trained skill rescued life from such great billows and such thick
-darkness and moored it in so perfect a calm and in so brilliant a light"
-- Lucretius
+for their valuable comments and suggestions.
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2003-2014 Mark Shelor
+Copyright (C) 2003-2008 Mark Shelor
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/Digest-SHA/shasum b/gnu/usr.bin/perl/cpan/Digest-SHA/shasum
index 32b71733bf7..a349ed7181e 100644
--- a/gnu/usr.bin/perl/cpan/Digest-SHA/shasum
+++ b/gnu/usr.bin/perl/cpan/Digest-SHA/shasum
@@ -1,18 +1,11 @@
#!perl -w
- ## shasum: filter for computing SHA digests (ref. sha1sum/md5sum)
- ##
- ## Copyright (C) 2003-2014 Mark Shelor, All Rights Reserved
- ##
- ## Version: 5.88
- ## Mon Mar 17 08:46:10 MST 2014
-
- ## shasum SYNOPSIS adapted from GNU Coreutils sha1sum.
- ## Add an "-a" option for algorithm selection, a "-p"
- ## option for portable digest computation, and a "-0"
- ## option for reading bit strings.
-
-my $POD = <<'END_OF_POD';
+ # shasum: filter for computing SHA digests (analogous to sha1sum)
+ #
+ # Copyright (C) 2003-2008 Mark Shelor, All Rights Reserved
+ #
+ # Version: 5.47
+ # Wed Apr 30 04:00:54 MST 2008
=head1 NAME
@@ -20,85 +13,88 @@ shasum - Print or Check SHA Checksums
=head1 SYNOPSIS
- Usage: shasum [OPTION]... [FILE]...
+ Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
Print or check SHA checksums.
With no FILE, or when FILE is -, read standard input.
- -a, --algorithm 1 (default), 224, 256, 384, 512, 512224, 512256
- -b, --binary read in binary mode
- -c, --check read SHA sums from the FILEs and check them
- -t, --text read in text mode (default)
- -p, --portable read in portable mode
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
produces same digest on Windows/Unix/Mac
- -0, --01 read in BITS mode
- ASCII '0' interpreted as 0-bit,
- ASCII '1' interpreted as 1-bit,
- all other characters ignored
+ -t, --text read files in text mode (default)
The following two options are useful only when verifying checksums:
- -s, --status don't output anything, status code shows success
- -w, --warn warn about improperly formatted checksum lines
-
- -h, --help display this help and exit
- -v, --version output version information and exit
- When verifying SHA-512/224 or SHA-512/256 checksums, indicate the
- algorithm explicitly using the -a option, e.g.
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
- shasum -a 512224 -c checksumfile
+ -h, --help display this help and exit
+ -v, --version output version information and exit
- The sums are computed as described in FIPS PUB 180-4. When checking,
- the input should be a former output of this program. The default
- mode is to print a line with checksum, a character indicating type
- (`*' for binary, ` ' for text, `?' for portable, `^' for BITS),
- and name for each FILE.
-
- Report shasum bugs to mshelor@cpan.org
+ The sums are computed as described in FIPS PUB 180-2. When checking,
+ the input should be a former output of this program. The default mode
+ is to print a line with checksum, a character indicating type (`*'
+ for binary, `?' for portable, ` ' for text), and name for each FILE.
=head1 DESCRIPTION
-Running I<shasum> is often the quickest way to compute SHA message
-digests. The user simply feeds data to the script through files or
-standard input, and then collects the results from standard output.
+The I<shasum> script provides the easiest and most convenient way to
+compute SHA message digests. Rather than writing a program, the user
+simply feeds data to the script via the command line, and waits for
+the results to be printed on standard output. Data can be fed to
+I<shasum> through files, standard input, or both.
-The following command shows how to compute digests for typical inputs
-such as the NIST test vector "abc":
+The following command shows how easy it is to compute digests for typical
+inputs such as the NIST test vector "abc":
- perl -e "print qq(abc)" | shasum
+ perl -e "print qw(abc)" | shasum
Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
- perl -e "print qq(abc)" | shasum -a 256
+ perl -e "print qw(abc)" | shasum -a 256
-Since I<shasum> mimics the behavior of the combined GNU I<sha1sum>,
-I<sha224sum>, I<sha256sum>, I<sha384sum>, and I<sha512sum> programs,
+Since I<shasum> uses the same interface employed by the familiar
+I<sha1sum> program (and its somewhat outmoded anscestor I<md5sum>),
you can install this script as a convenient drop-in replacement.
-Unlike the GNU programs, I<shasum> encompasses the full SHA standard by
-allowing partial-byte inputs. This is accomplished through the BITS
-option (I<-0>). The following example computes the SHA-224 digest of
-the 7-bit message I<0001100>:
-
- perl -e "print qq(0001100)" | shasum -0 -a 224
-
=head1 AUTHOR
-Copyright (c) 2003-2014 Mark Shelor <mshelor@cpan.org>.
+Copyright (c) 2003-2008 Mark Shelor <mshelor@cpan.org>.
=head1 SEE ALSO
-I<shasum> is implemented using the Perl module L<Digest::SHA> or
+shasum is implemented using the Perl module L<Digest::SHA> or
L<Digest::SHA::PurePerl>.
=cut
-END_OF_POD
-
use strict;
-use Fcntl;
+use FileHandle;
use Getopt::Long;
-my $VERSION = "5.88";
+my $VERSION = "5.47";
+
+
+ # Try to use Digest::SHA, since it's faster. If not installed,
+ # use Digest::SHA::PurePerl instead.
+
+my $MOD_PREFER = "Digest::SHA";
+my $MOD_SECOND = "Digest::SHA::PurePerl";
+
+my $module = $MOD_PREFER;
+eval "require $module";
+if ($@) {
+ $module = $MOD_SECOND;
+ eval "require $module";
+ die "Unable to find $MOD_PREFER or $MOD_SECOND\n" if $@;
+}
+
+
+ # Usage statement adapted from Ulrich Drepper's md5sum.
+ # Include an "-a" option for algorithm selection,
+ # and a "-p" option for portable digest computation.
sub usage {
my($err, $msg) = @_;
@@ -108,25 +104,41 @@ sub usage {
warn($msg . "Type shasum -h for help\n");
exit($err);
}
- my($USAGE) = $POD =~ /SYNOPSIS(.+?)^=/sm;
- $USAGE =~ s/^\s*//;
- $USAGE =~ s/\s*$//;
- $USAGE =~ s/^ //gm;
- print $USAGE, "\n";
- exit($err);
-}
+ print <<'END_OF_USAGE';
+Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+Print or check SHA checksums.
+With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+The following two options are useful only when verifying checksums:
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
- ## Sync stdout and stderr by forcing a flush after every write
+ -h, --help display this help and exit
+ -v, --version output version information and exit
-select((select(STDOUT), $| = 1)[0]);
-select((select(STDERR), $| = 1)[0]);
+The sums are computed as described in FIPS PUB 180-2. When checking, the
+input should be a former output of this program. The default mode is to
+print a line with checksum, a character indicating type (`*' for binary,
+`?' for portable, ` ' for text), and name for each FILE.
+Report bugs to <mshelor@cpan.org>.
+END_OF_USAGE
+ exit($err);
+}
- ## Collect options from command line
+
+ # Collect options from command line
my ($alg, $binary, $check, $text, $status, $warn, $help, $version);
-my ($portable, $BITS, $modules, $versions);
+my ($portable);
eval { Getopt::Long::Configure ("bundling") };
GetOptions(
@@ -134,190 +146,123 @@ GetOptions(
't|text' => \$text, 'a|algorithm=i' => \$alg,
's|status' => \$status, 'w|warn' => \$warn,
'h|help' => \$help, 'v|version' => \$version,
- 'p|portable' => \$portable,
- '0|01' => \$BITS,
- 'M|MODULES=s' => \$modules,
- 'V|VERSIONS' => \$versions,
+ 'p|portable' => \$portable
) or usage(1, "");
- ## Deal with help requests and incorrect uses
+ # Deal with help requests and incorrect uses
usage(0)
if $help;
usage(1, "shasum: Ambiguous file mode\n")
- if scalar(grep {defined $_} ($binary, $portable, $text, $BITS)) > 1;
+ if scalar(grep { defined $_ } ($binary, $portable, $text)) > 1;
usage(1, "shasum: --warn option used only when verifying checksums\n")
if $warn && !$check;
usage(1, "shasum: --status option used only when verifying checksums\n")
if $status && !$check;
- ## Try to use Digest::SHA. If not installed, use the slower
- ## but functionally equivalent Digest::SHA::PurePerl instead.
-
- ## If option -M "Mod::Num1 Mod::Num2 ..." is invoked, try
- ## those modules instead, in the order indicated.
-
-my @MODS = defined $modules
- ? split(" ", $modules)
- : qw(Digest::SHA Digest::SHA::PurePerl);
+ # Default to SHA-1 unless overriden by command line option
-my $module;
-for (@MODS) {
- my $mod = $_;
- if (eval "require $mod") {
- $module = $mod;
- last;
- }
-}
-die "shasum: Unable to find " . join(" or ", @MODS) . "\n"
- unless defined $module;
-
-
- ## Default to SHA-1 unless overridden by command line option
-
-$alg = 1 unless defined $alg;
-grep { $_ == $alg } (1, 224, 256, 384, 512, 512224, 512256)
+$alg = 1 unless $alg;
+grep { $_ == $alg } (1, 224, 256, 384, 512)
or usage(1, "shasum: Unrecognized algorithm\n");
- ## Display version information if requested
+ # Display version information if requested
if ($version) {
print "$VERSION\n";
exit(0);
}
-if ($versions) {
- print "shasum $VERSION\n";
- print "$module ", eval "\$${module}::VERSION", "\n";
- print "perl ", defined $^V ? sprintf("%vd", $^V) : $], "\n";
- exit(0);
-}
-
- ## Try to figure out if the OS is DOS-like. If it is,
- ## default to binary mode when reading files, unless
- ## explicitly overridden by command line "--text" or
- ## "--portable" options.
+ # Try to figure out if the OS is DOS-like. If it is,
+ # default to binary mode when reading files, unless
+ # explicitly overriden by command line "--text" or
+ # "--portable" options.
my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin)$/);
if ($isDOSish) { $binary = 1 unless $text || $portable }
-my $modesym = $binary ? '*' : ($portable ? '?' : ($BITS ? '^' : ' '));
+my $modesym = $binary ? '*' : ($portable ? '?' : ' ');
- ## Read from STDIN (-) if no files listed on command line
+ # Read from STDIN (-) if no files listed on command line
@ARGV = ("-") unless @ARGV;
- ## sumfile($file): computes SHA digest of $file
+ # sumfile($file): computes SHA digest of $file
sub sumfile {
my $file = shift;
- my $mode = $portable ? 'p' : ($binary ? 'b' : ($BITS ? '0' : ''));
+ my $mode = $portable ? 'p' : ($binary ? 'b' : '');
my $digest = eval { $module->new($alg)->addfile($file, $mode) };
- if ($@) { warn "shasum: $file: $!\n"; return }
+ if ($@) {
+ warn "shasum: $file: $!\n";
+ return;
+ }
+
$digest->hexdigest;
}
- ## %len2alg: maps hex digest length to SHA algorithm
+ # %len2alg: maps hex digest length to SHA algorithm
my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
-$len2alg{56} = 512224 if $alg == 512224;
-$len2alg{64} = 512256 if $alg == 512256;
- ## unescape: convert backslashed filename to plain filename
+ # Verify checksums if requested
-sub unescape {
- $_ = shift;
- s/\\\\/\0/g;
- s/\\n/\n/g;
- return if /\\/;
- s/\0/\\/g;
- return $_;
-}
+if ($check) {
+ my $checkfile = shift(@ARGV);
+ my ($err, $read_errs, $match_errs) = (0, 0, 0);
+ my ($num_files, $num_checksums) = (0, 0);
+ my ($fh, $sum, $fname, $rsp, $digest);
-
- ## verify: confirm the digest values in a checksum file
-
-sub verify {
- my $checkfile = shift;
- my ($err, $fmt_errs, $read_errs, $match_errs) = (0, 0, 0, 0);
- my ($num_lines, $num_files) = (0, 0);
- my ($bslash, $sum, $fname, $rsp, $digest);
-
- local *FH;
- $checkfile eq '-' and open(FH, '< -')
- and $checkfile = 'standard input'
- or sysopen(FH, $checkfile, O_RDONLY)
- or die "shasum: $checkfile: $!\n";
- while (<FH>) {
- next if /^#/; s/\n$//; s/^[ \t]+//; $num_lines++;
- $bslash = s/^\\//;
- ($sum, $modesym, $fname) =
- /^([\da-fA-F]+)[ \t]([ *?^])([^\0]*)/;
- $alg = defined $sum ? $len2alg{length($sum)} : undef;
- $fname = unescape($fname) if defined $fname && $bslash;
- if (grep { ! defined $_ } ($alg, $sum, $modesym, $fname)) {
- $alg = 1 unless defined $alg;
+ die "shasum: $checkfile: $!\n"
+ unless $fh = FileHandle->new($checkfile, "r");
+ while (<$fh>) {
+ s/\s+$//;
+ ($sum, $modesym, $fname) = /^(\S+) (.)(.*)$/;
+ ($binary, $portable, $text) =
+ map { $_ eq $modesym } ('*', '?', ' ');
+ unless ($alg = $len2alg{length($sum)}) {
warn("shasum: $checkfile: $.: improperly " .
- "formatted SHA$alg checksum line\n") if $warn;
- $fmt_errs++;
+ "formatted SHA checksum line\n") if $warn;
next;
}
- $fname =~ s/\r$// unless -e $fname;
$rsp = "$fname: "; $num_files++;
- ($binary, $portable, $text, $BITS) =
- map { $_ eq $modesym } ('*', '?', ' ', '^');
unless ($digest = sumfile($fname)) {
$rsp .= "FAILED open or read\n";
$err = 1; $read_errs++;
}
else {
+ $num_checksums++;
if (lc($sum) eq $digest) { $rsp .= "OK\n" }
else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
}
print $rsp unless $status;
}
- close(FH);
- unless ($num_files) {
- $alg = 1 unless defined $alg;
- warn("shasum: $checkfile: no properly formatted " .
- "SHA$alg checksum lines found\n");
- $err = 1;
- }
- elsif (! $status) {
- warn("shasum: WARNING: $fmt_errs line" . ($fmt_errs>1?
- 's are':' is') . " improperly formatted\n") if $fmt_errs;
- warn("shasum: WARNING: $read_errs listed file" .
- ($read_errs>1?'s':'') . " could not be read\n") if $read_errs;
- warn("shasum: WARNING: $match_errs computed checksum" .
- ($match_errs>1?'s':'') . " did NOT match\n") if $match_errs;
+ $fh->close;
+ unless ($status) {
+ warn("shasum: WARNING: $read_errs of $num_files listed " .
+ "files could not be read\n") if $read_errs;
+ warn("shasum: WARNING: $match_errs of $num_checksums " .
+ "computed checksums did NOT match\n") if $match_errs;
}
- return($err == 0);
+ exit($err);
}
- ## Verify or compute SHA checksums of requested files
+ # Compute and display SHA checksums of requested files
my($file, $digest);
-my $STATUS = 0;
for $file (@ARGV) {
- if ($check) { $STATUS = 1 unless verify($file) }
- elsif ($digest = sumfile($file)) {
- if ($file =~ /[\n\\]/) {
- $file =~ s/\\/\\\\/g; $file =~ s/\n/\\n/g;
- $digest = "\\$digest";
- }
+ if ($digest = sumfile($file)) {
print "$digest $modesym", "$file\n";
}
- else { $STATUS = 1 }
}
-exit($STATUS)
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/bin/instmodsh b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/bin/instmodsh
index 8b9aa95ae74..5874aa61c7a 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/bin/instmodsh
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/bin/instmodsh
@@ -82,8 +82,8 @@ sub list_installed {
print("$class files in $module are:\n ",
join("\n ", @files), "\n");
}
- else {
- print($@);
+ else {
+ print($@);
}
};
@@ -99,8 +99,8 @@ sub list_directories {
print("$class directories in $module are:\n ",
join("\n ", @dirs), "\n");
}
- else {
- print($@);
+ else {
+ print($@);
}
}
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm
index f45d41d0323..f9b474de16f 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm
@@ -8,16 +8,12 @@ use warnings;
require Exporter;
our @ISA = qw(Exporter);
-our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
- warn_if_old_packlist test_s cp_nonempty);
-our $VERSION = '6.98';
+our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
+ warn_if_old_packlist);
+our $VERSION = '6.56';
my $Is_VMS = $^O eq 'VMS';
-eval { require Time::HiRes; die unless Time::HiRes->can("stat"); };
-*mtime = $@ ?
- sub { [ stat($_[0])]->[9] } :
- sub { [Time::HiRes::stat($_[0])]->[9] } ;
=head1 NAME
@@ -103,7 +99,7 @@ sub pod2man {
if( !eval { require Pod::Man } ) {
warn "Pod::Man is not available: $@".
"Man pages will not be generated during this install.\n";
- return 0;
+ return undef;
}
}
require Getopt::Long;
@@ -112,7 +108,7 @@ sub pod2man {
# our arguments into @ARGV. Should be safe.
my %options = ();
Getopt::Long::config ('bundling_override');
- Getopt::Long::GetOptions (\%options,
+ Getopt::Long::GetOptions (\%options,
'section|s=s', 'release|r=s', 'center|c=s',
'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l',
@@ -135,8 +131,8 @@ sub pod2man {
my ($pod, $man) = splice(@ARGV, 0, 2);
next if ((-e $man) &&
- (mtime($man) > mtime($pod)) &&
- (mtime($man) > mtime("Makefile")));
+ (-M $man < -M $pod) &&
+ (-M $man < -M "Makefile"));
print "Manifying $man\n";
@@ -178,7 +174,7 @@ PACKLIST_WARNING
=item B<perllocal_install>
- perl "-MExtUtils::Command::MM" -e perllocal_install
+ perl "-MExtUtils::Command::MM" -e perllocal_install
<type> <module name> <key> <value> ...
# VMS only, key|value pairs come on STDIN
@@ -197,7 +193,7 @@ Key/value pairs are extra information about the module. Fields include:
installed into which directory your module was out into
LINKTYPE dynamic or static linking
VERSION module version number
- EXE_FILES any executables installed in a space seperated
+ EXE_FILES any executables installed in a space seperated
list
=cut
@@ -213,9 +209,9 @@ sub perllocal_install {
my $pod;
$pod = sprintf <<POD, scalar localtime;
=head2 %s: C<$type> L<$name|$name>
-
+
=over 4
-
+
POD
do {
@@ -223,9 +219,9 @@ POD
$pod .= <<POD
=item *
-
+
C<$key: $val>
-
+
POD
} while(@mod_info);
@@ -272,43 +268,8 @@ WARNING
}
-=item B<test_s>
-
- perl "-MExtUtils::Command::MM" -e test_s <file>
-
-Tests if a file exists and is not empty (size > 0).
-I<Exits> with 0 if it does, 1 if it does not.
-
-=cut
-
-sub test_s {
- exit(-s $ARGV[0] ? 0 : 1);
-}
-
-=item B<cp_nonempty>
-
- perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm>
-
-Tests if the source file exists and is not empty (size > 0). If it is not empty
-it copies it to the given destination with the given permissions.
-
=back
=cut
-sub cp_nonempty {
- my @args = @ARGV;
- return 0 unless -s $args[0];
- require ExtUtils::Command;
- {
- local @ARGV = @args[0,1];
- ExtUtils::Command::cp(@ARGV);
- }
- {
- local @ARGV = @args[2,1];
- ExtUtils::Command::chmod(@ARGV);
- }
-}
-
-
1;
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm
index 2d21e12d824..ea4dac4ae7c 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm
@@ -2,7 +2,7 @@ package ExtUtils::Liblist;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
use File::Spec;
require ExtUtils::Liblist::Kid;
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm
index e39c8b27ced..b807e97cc86 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm
@@ -6,249 +6,211 @@ package ExtUtils::Liblist::Kid;
# $self is not a Makemaker.
use 5.006;
-
# Broken out of MakeMaker from version 4.11
use strict;
-use warnings;
-our $VERSION = '6.98';
+our $VERSION = 6.56;
-use ExtUtils::MakeMaker::Config;
+use Config;
use Cwd 'cwd';
use File::Basename;
use File::Spec;
sub ext {
- if ( $^O eq 'VMS' ) { return &_vms_ext; }
- elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; }
- else { return &_unix_os2_ext; }
+ if ($^O eq 'VMS') { return &_vms_ext; }
+ elsif($^O eq 'MSWin32') { return &_win32_ext; }
+ else { return &_unix_os2_ext; }
}
sub _unix_os2_ext {
- my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
+ my($self,$potential_libs, $verbose, $give_libs) = @_;
$verbose ||= 0;
- if ( $^O =~ /os2|android/ and $Config{perllibs} ) {
-
- # Dynamic libraries are not transitive, so we may need including
- # the libraries linked against perl.dll/libperl.so again.
+ if ($^O =~ 'os2' and $Config{perllibs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
- $potential_libs .= " " if $potential_libs;
- $potential_libs .= $Config{perllibs};
+ $potential_libs .= " " if $potential_libs;
+ $potential_libs .= $Config{perllibs};
}
- return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
+ return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
warn "Potential libraries are '$potential_libs':\n" if $verbose;
- my ( $so ) = $Config{so};
- my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs};
+ my($so) = $Config{so};
+ my($libs) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs};
my $Config_libext = $Config{lib_ext} || ".a";
- my $Config_dlext = $Config{dlext};
+
# compute $extralibs, $bsloadlibs and $ldloadlibs from
# $potential_libs
# this is a rewrite of Andy Dougherty's extliblist in perl
- my ( @searchpath ); # from "-L/path" entries in $potential_libs
- my ( @libpath ) = split " ", $Config{'libpth'};
- my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen );
- my ( @libs, %libs_seen );
- my ( $fullname, @fullname );
- my ( $pwd ) = cwd(); # from Cwd.pm
- my ( $found ) = 0;
-
- foreach my $thislib ( split ' ', $potential_libs ) {
-
- # Handle possible linker path arguments.
- if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # save path flag type
- my ( $ptype ) = $1;
- unless ( -d $thislib ) {
- warn "$ptype$thislib ignored, directory does not exist\n"
- if $verbose;
- next;
- }
- my ( $rtype ) = $ptype;
- if ( ( $ptype eq '-R' ) or ( $ptype =~ m!^-Wl,-[Rr]! ) ) {
- if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) {
- $rtype = '-Wl,-R';
- }
- elsif ( $Config{'lddlflags'} =~ /-R/ ) {
- $rtype = '-R';
- }
- }
- unless ( File::Spec->file_name_is_absolute( $thislib ) ) {
- warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
- $thislib = $self->catdir( $pwd, $thislib );
- }
- push( @searchpath, $thislib );
- push( @extralibs, "$ptype$thislib" );
- push( @ldloadlibs, "$rtype$thislib" );
- next;
- }
-
- if ( $thislib =~ m!^-Wl,! ) {
- push( @extralibs, $thislib );
- push( @ldloadlibs, $thislib );
- next;
- }
-
- # Handle possible library arguments.
- unless ( $thislib =~ s/^-l// ) {
- warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
- next;
- }
-
- my ( $found_lib ) = 0;
- foreach my $thispth ( @searchpath, @libpath ) {
-
- # Try to find the full name of the library. We need this to
- # determine whether it's a dynamically-loadable library or not.
- # This tends to be subject to various os-specific quirks.
- # For gcc-2.6.2 on linux (March 1995), DLD can not load
- # .sa libraries, with the exception of libm.sa, so we
- # deliberately skip them.
- if ( @fullname = $self->lsdir( $thispth, "^\Qlib$thislib.$so.\E[0-9]+" ) ) {
-
- # Take care that libfoo.so.10 wins against libfoo.so.9.
- # Compare two libraries to find the most recent version
- # number. E.g. if you have libfoo.so.9.0.7 and
- # libfoo.so.10.1, first convert all digits into two
- # decimal places. Then we'll add ".00" to the shorter
- # strings so that we're comparing strings of equal length
- # Thus we'll compare libfoo.so.09.07.00 with
- # libfoo.so.10.01.00. Some libraries might have letters
- # in the version. We don't know what they mean, but will
- # try to skip them gracefully -- we'll set any letter to
- # '0'. Finally, sort in reverse so we can take the
- # first element.
-
- #TODO: iterate through the directory instead of sorting
-
- $fullname = "$thispth/" . (
- sort {
- my ( $ma ) = $a;
- my ( $mb ) = $b;
- $ma =~ tr/A-Za-z/0/s;
- $ma =~ s/\b(\d)\b/0$1/g;
- $mb =~ tr/A-Za-z/0/s;
- $mb =~ s/\b(\d)\b/0$1/g;
- while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; }
- while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; }
-
- # Comparison deliberately backwards
- $mb cmp $ma;
- } @fullname
- )[0];
- }
- elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" )
- && ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) )
- {
- }
- elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" )
- && ( $Config{'archname'} !~ /RM\d\d\d-svr4/ )
- && ( $thislib .= "_s" ) )
- { # we must explicitly use _s version
- }
- elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) {
- }
- elsif ( defined( $Config_dlext )
- && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) )
- {
- }
- elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) {
- }
- elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) {
- }
- elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) {
- }
- elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) {
- }
- elsif ($^O eq 'dgux'
- && -l ( $fullname = "$thispth/lib$thislib$Config_libext" )
- && readlink( $fullname ) =~ /^elink:/s )
- {
-
- # Some of DG's libraries look like misconnected symbolic
- # links, but development tools can follow them. (They
- # look like this:
- #
- # libm.a -> elink:${SDE_PATH:-/usr}/sde/\
- # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
- #
- # , the compilation tools expand the environment variables.)
- }
- else {
- warn "$thislib not found in $thispth\n" if $verbose;
- next;
- }
- warn "'-l$thislib' found at $fullname\n" if $verbose;
- push @libs, $fullname unless $libs_seen{$fullname}++;
- $found++;
- $found_lib++;
-
- # Now update library lists
-
- # what do we know about this library...
- my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ );
- my $in_perl = ( $libs =~ /\B-l\Q${thislib}\E\b/s );
+ my(@searchpath); # from "-L/path" entries in $potential_libs
+ my(@libpath) = split " ", $Config{'libpth'};
+ my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen);
+ my(@libs, %libs_seen);
+ my($fullname, @fullname);
+ my($pwd) = cwd(); # from Cwd.pm
+ my($found) = 0;
+
+ foreach my $thislib (split ' ', $potential_libs) {
+
+ # Handle possible linker path arguments.
+ if ($thislib =~ s/^(-[LR]|-Wl,-R)//){ # save path flag type
+ my($ptype) = $1;
+ unless (-d $thislib){
+ warn "$ptype$thislib ignored, directory does not exist\n"
+ if $verbose;
+ next;
+ }
+ my($rtype) = $ptype;
+ if (($ptype eq '-R') or ($ptype eq '-Wl,-R')) {
+ if ($Config{'lddlflags'} =~ /-Wl,-R/) {
+ $rtype = '-Wl,-R';
+ } elsif ($Config{'lddlflags'} =~ /-R/) {
+ $rtype = '-R';
+ }
+ }
+ unless (File::Spec->file_name_is_absolute($thislib)) {
+ warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
+ $thislib = $self->catdir($pwd,$thislib);
+ }
+ push(@searchpath, $thislib);
+ push(@extralibs, "$ptype$thislib");
+ push(@ldloadlibs, "$rtype$thislib");
+ next;
+ }
+
+ # Handle possible library arguments.
+ unless ($thislib =~ s/^-l//){
+ warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
+ next;
+ }
+
+ my($found_lib)=0;
+ foreach my $thispth (@searchpath, @libpath) {
+
+ # Try to find the full name of the library. We need this to
+ # determine whether it's a dynamically-loadable library or not.
+ # This tends to be subject to various os-specific quirks.
+ # For gcc-2.6.2 on linux (March 1995), DLD can not load
+ # .sa libraries, with the exception of libm.sa, so we
+ # deliberately skip them.
+ if (@fullname =
+ $self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+")){
+ # Take care that libfoo.so.10 wins against libfoo.so.9.
+ # Compare two libraries to find the most recent version
+ # number. E.g. if you have libfoo.so.9.0.7 and
+ # libfoo.so.10.1, first convert all digits into two
+ # decimal places. Then we'll add ".00" to the shorter
+ # strings so that we're comparing strings of equal length
+ # Thus we'll compare libfoo.so.09.07.00 with
+ # libfoo.so.10.01.00. Some libraries might have letters
+ # in the version. We don't know what they mean, but will
+ # try to skip them gracefully -- we'll set any letter to
+ # '0'. Finally, sort in reverse so we can take the
+ # first element.
+
+ #TODO: iterate through the directory instead of sorting
+
+ $fullname = "$thispth/" .
+ (sort { my($ma) = $a;
+ my($mb) = $b;
+ $ma =~ tr/A-Za-z/0/s;
+ $ma =~ s/\b(\d)\b/0$1/g;
+ $mb =~ tr/A-Za-z/0/s;
+ $mb =~ s/\b(\d)\b/0$1/g;
+ while (length($ma) < length($mb)) { $ma .= ".00"; }
+ while (length($mb) < length($ma)) { $mb .= ".00"; }
+ # Comparison deliberately backwards
+ $mb cmp $ma;} @fullname)[0];
+ } elsif (-f ($fullname="$thispth/lib$thislib.$so")
+ && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){
+ } elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext")
+ && ($Config{'archname'} !~ /RM\d\d\d-svr4/)
+ && ($thislib .= "_s") ){ # we must explicitly use _s version
+ } elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){
+ } elsif (-f ($fullname="$thispth/$thislib$Config_libext")){
+ } elsif (-f ($fullname="$thispth/lib$thislib.dll$Config_libext")){
+ } elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){
+ } elsif ($^O eq 'dgux'
+ && -l ($fullname="$thispth/lib$thislib$Config_libext")
+ && readlink($fullname) =~ /^elink:/s) {
+ # Some of DG's libraries look like misconnected symbolic
+ # links, but development tools can follow them. (They
+ # look like this:
+ #
+ # libm.a -> elink:${SDE_PATH:-/usr}/sde/\
+ # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
+ #
+ # , the compilation tools expand the environment variables.)
+ } else {
+ warn "$thislib not found in $thispth\n" if $verbose;
+ next;
+ }
+ warn "'-l$thislib' found at $fullname\n" if $verbose;
+ push @libs, $fullname unless $libs_seen{$fullname}++;
+ $found++;
+ $found_lib++;
+
+ # Now update library lists
+
+ # what do we know about this library...
+ my $is_dyna = ($fullname !~ /\Q$Config_libext\E\z/);
+ my $in_perl = ($libs =~ /\B-l\Q${thislib}\E\b/s);
# include the path to the lib once in the dynamic linker path
# but only if it is a dynamic lib and not in Perl itself
- my ( $fullnamedir ) = dirname( $fullname );
+ my($fullnamedir) = dirname($fullname);
push @ld_run_path, $fullnamedir
- if $is_dyna
- && !$in_perl
- && !$ld_run_path_seen{$fullnamedir}++;
-
- # Do not add it into the list if it is already linked in
- # with the main perl executable.
- # We have to special-case the NeXT, because math and ndbm
- # are both in libsys_s
- unless (
- $in_perl
- || ( $Config{'osname'} eq 'next'
- && ( $thislib eq 'm' || $thislib eq 'ndbm' ) )
- )
- {
- push( @extralibs, "-l$thislib" );
- }
-
- # We might be able to load this archive file dynamically
- if ( ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' )
- || ( $Config{'dlsrc'} =~ /dl_dld/ ) )
- {
-
- # We push -l$thislib instead of $fullname because
- # it avoids hardwiring a fixed path into the .bs file.
- # Mkbootstrap will automatically add dl_findfile() to
- # the .bs file if it sees a name in the -l format.
- # USE THIS, when dl_findfile() is fixed:
- # push(@bsloadlibs, "-l$thislib");
- # OLD USE WAS while checking results against old_extliblist
- push( @bsloadlibs, "$fullname" );
- }
- else {
- if ( $is_dyna ) {
-
+ if $is_dyna && !$in_perl &&
+ !$ld_run_path_seen{$fullnamedir}++;
+
+ # Do not add it into the list if it is already linked in
+ # with the main perl executable.
+ # We have to special-case the NeXT, because math and ndbm
+ # are both in libsys_s
+ unless ($in_perl ||
+ ($Config{'osname'} eq 'next' &&
+ ($thislib eq 'm' || $thislib eq 'ndbm')) ){
+ push(@extralibs, "-l$thislib");
+ }
+
+ # We might be able to load this archive file dynamically
+ if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0')
+ || ($Config{'dlsrc'} =~ /dl_dld/) )
+ {
+ # We push -l$thislib instead of $fullname because
+ # it avoids hardwiring a fixed path into the .bs file.
+ # Mkbootstrap will automatically add dl_findfile() to
+ # the .bs file if it sees a name in the -l format.
+ # USE THIS, when dl_findfile() is fixed:
+ # push(@bsloadlibs, "-l$thislib");
+ # OLD USE WAS while checking results against old_extliblist
+ push(@bsloadlibs, "$fullname");
+ } else {
+ if ($is_dyna){
# For SunOS4, do not add in this shared library if
# it is already linked in the main perl executable
- push( @ldloadlibs, "-l$thislib" )
- unless ( $in_perl and $^O eq 'sunos' );
- }
- else {
- push( @ldloadlibs, "-l$thislib" );
- }
- }
- last; # found one here so don't bother looking further
- }
- warn "Warning (mostly harmless): " . "No library found for -l$thislib\n"
- unless $found_lib > 0;
+ push(@ldloadlibs, "-l$thislib")
+ unless ($in_perl and $^O eq 'sunos');
+ } else {
+ push(@ldloadlibs, "-l$thislib");
+ }
+ }
+ last; # found one here so don't bother looking further
+ }
+ warn "Note (probably harmless): "
+ ."No library found for -l$thislib\n"
+ unless $found_lib>0;
}
- unless ( $found ) {
- return ( '', '', '', '', ( $give_libs ? \@libs : () ) );
+ unless( $found ) {
+ return ('','','','', ($give_libs ? \@libs : ()));
}
else {
- return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) );
+ return ("@extralibs", "@bsloadlibs", "@ldloadlibs",
+ join(":",@ld_run_path), ($give_libs ? \@libs : ()));
}
}
@@ -256,379 +218,329 @@ sub _win32_ext {
require Text::ParseWords;
- my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
+ my($self, $potential_libs, $verbose, $give_libs) = @_;
$verbose ||= 0;
# If user did not supply a list, we punt.
# (caller should probably use the list in $Config{libs})
- return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs;
+ return ("", "", "", "", ($give_libs ? [] : ())) unless $potential_libs;
+
+ my $cc = $Config{cc};
+ my $VC = $cc =~ /^cl/i;
+ my $BC = $cc =~ /^bcc/i;
+ my $GC = $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+ my $libs = $Config{'perllibs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+ my(@libs, %libs_seen);
+
+ if ($libs and $potential_libs !~ /:nodefault/i) {
+ # If Config.pm defines a set of default libs, we always
+ # tack them on to the user-supplied list, unless the user
+ # specified :nodefault
+
+ $potential_libs .= " " if $potential_libs;
+ $potential_libs .= $libs;
+ }
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
- # TODO: make this use MM_Win32.pm's compiler detection
- my %libs_seen;
- my @extralibs;
- my $cc = $Config{cc} || '';
- my $VC = $cc =~ /\bcl\b/i;
- my $GC = $cc =~ /\bgcc\b/i;
+ # normalize to forward slashes
+ $libpth =~ s,\\,/,g;
+ $potential_libs =~ s,\\,/,g;
- my $libext = _win32_lib_extensions();
- my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs
- my @libpath = _win32_default_search_paths( $VC, $GC );
- my $pwd = cwd(); # from Cwd.pm
- my $search = 1;
+ # compute $extralibs from $potential_libs
- # compute @extralibs from $potential_libs
- my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose );
- for ( @lib_search_list ) {
+ my @searchpath; # from "-L/path" in $potential_libs
+ my @libpath = Text::ParseWords::quotewords('\s+', 0, $libpth);
+ my @extralibs;
+ my $pwd = cwd(); # from Cwd.pm
+ my $lib = '';
+ my $found = 0;
+ my $search = 1;
+ my($fullname);
- my $thislib = $_;
+ # add "$Config{installarchlib}/CORE" to default search path
+ push @libpath, "$Config{installarchlib}/CORE";
- # see if entry is a flag
- if ( /^:\w+$/ ) {
- $search = 0 if lc eq ':nosearch';
- $search = 1 if lc eq ':search';
- _debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i;
- next;
- }
+ if ($VC and exists $ENV{LIB} and $ENV{LIB}) {
+ push @libpath, split /;/, $ENV{LIB};
+ }
- # if searching is disabled, do compiler-specific translations
- unless ( $search ) {
- s/^-l(.+)$/$1.lib/ unless $GC;
- s/^-L/-libpath:/ if $VC;
- push( @extralibs, $_ );
- next;
- }
+ foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){
- # handle possible linker path arguments
- if ( s/^-L// and not -d ) {
- _debug( "$thislib ignored, directory does not exist\n", $verbose );
- next;
- }
- elsif ( -d ) {
- unless ( File::Spec->file_name_is_absolute( $_ ) ) {
- warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
- $_ = $self->catdir( $pwd, $_ );
- }
- push( @searchpath, $_ );
- next;
- }
-
- my @paths = ( @searchpath, @libpath );
- my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC );
+ my $thislib = $_;
- if ( !$fullname ) {
- warn "Warning (mostly harmless): No library found for $thislib\n";
- next;
- }
+ # see if entry is a flag
+ if (/^:\w+$/) {
+ $search = 0 if lc eq ':nosearch';
+ $search = 1 if lc eq ':search';
+ warn "Ignoring unknown flag '$thislib'\n"
+ if $verbose and !/^:(no)?(search|default)$/i;
+ next;
+ }
+
+ # if searching is disabled, do compiler-specific translations
+ unless ($search) {
+ s/^-l(.+)$/$1.lib/ unless $GC;
+ s/^-L/-libpath:/ if $VC;
+ push(@extralibs, $_);
+ $found++;
+ next;
+ }
+
+ # handle possible linker path arguments
+ if (s/^-L// and not -d) {
+ warn "$thislib ignored, directory does not exist\n"
+ if $verbose;
+ next;
+ }
+ elsif (-d) {
+ unless (File::Spec->file_name_is_absolute($_)) {
+ warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
+ $_ = $self->catdir($pwd,$_);
+ }
+ push(@searchpath, $_);
+ next;
+ }
+
+ # handle possible library arguments
+ if (s/^-l// and $GC and !/^lib/i) {
+ $_ = "lib$_";
+ }
+ $_ .= $libext if !/\Q$libext\E$/i;
+
+ my $secondpass = 0;
+ LOOKAGAIN:
+
+ # look for the file itself
+ if (-f) {
+ warn "'$thislib' found as '$_'\n" if $verbose;
+ $found++;
+ push(@extralibs, $_);
+ next;
+ }
+
+ my $found_lib = 0;
+ foreach my $thispth (@searchpath, @libpath){
+ unless (-f ($fullname="$thispth\\$_")) {
+ warn "'$thislib' not found as '$fullname'\n" if $verbose;
+ next;
+ }
+ warn "'$thislib' found as '$fullname'\n" if $verbose;
+ $found++;
+ $found_lib++;
+ push(@extralibs, $fullname);
+ push @libs, $fullname unless $libs_seen{$fullname}++;
+ last;
+ }
+
+ # do another pass with (or without) leading 'lib' if they used -l
+ if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) {
+ if ($GC) {
+ goto LOOKAGAIN if s/^lib//i;
+ }
+ elsif (!/^lib/i) {
+ $_ = "lib$_";
+ goto LOOKAGAIN;
+ }
+ }
+
+ # give up
+ warn "Note (probably harmless): "
+ ."No library found for $thislib\n"
+ unless $found_lib>0;
- _debug( "'$thislib' found as '$fullname'\n", $verbose );
- push( @extralibs, $fullname );
- $libs_seen{$fullname} = 1 if $path; # why is this a special case?
}
- my @libs = keys %libs_seen;
-
- return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs;
+ return ('','','','', ($give_libs ? \@libs : ())) unless $found;
# make sure paths with spaces are properly quoted
- @extralibs = map { /\s/ ? qq["$_"] : $_ } @extralibs;
- @libs = map { /\s/ ? qq["$_"] : $_ } @libs;
-
- my $lib = join( ' ', @extralibs );
+ @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs;
+ @libs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @libs;
+ $lib = join(' ',@extralibs);
# normalize back to backward slashes (to help braindead tools)
# XXX this may break equally braindead GNU tools that don't understand
# backslashes, either. Seems like one can't win here. Cursed be CP/M.
$lib =~ s,/,\\,g;
- _debug( "Result: $lib\n", $verbose );
- wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib;
-}
-
-sub _win32_make_lib_search_list {
- my ( $potential_libs, $verbose ) = @_;
-
- # If Config.pm defines a set of default libs, we always
- # tack them on to the user-supplied list, unless the user
- # specified :nodefault
- my $libs = $Config{'perllibs'};
- $potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i;
- _debug( "Potential libraries are '$potential_libs':\n", $verbose );
-
- $potential_libs =~ s,\\,/,g; # normalize to forward slashes
-
- my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs );
-
- return @list;
-}
-
-sub _win32_default_search_paths {
- my ( $VC, $GC ) = @_;
-
- my $libpth = $Config{'libpth'} || '';
- $libpth =~ s,\\,/,g; # normalize to forward slashes
-
- my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth );
- push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path
-
- push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB};
- push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH};
-
- return @libpath;
-}
-
-sub _win32_search_file {
- my ( $thislib, $libext, $paths, $verbose, $GC ) = @_;
-
- my @file_list = _win32_build_file_list( $thislib, $GC, $libext );
-
- for my $lib_file ( @file_list ) {
- for my $path ( @{$paths} ) {
- my $fullname = $lib_file;
- $fullname = "$path\\$fullname" if $path;
-
- return ( $fullname, $path ) if -f $fullname;
-
- _debug( "'$thislib' not found as '$fullname'\n", $verbose );
- }
- }
-
- return;
-}
-
-sub _win32_build_file_list {
- my ( $lib, $GC, $extensions ) = @_;
-
- my @pre_fixed = _win32_build_prefixed_list( $lib, $GC );
- return map _win32_attach_extensions( $_, $extensions ), @pre_fixed;
-}
-
-sub _win32_build_prefixed_list {
- my ( $lib, $GC ) = @_;
-
- return $lib if $lib !~ s/^-l//;
- return $lib if $lib =~ /^lib/ and !$GC;
-
- ( my $no_prefix = $lib ) =~ s/^lib//i;
- $lib = "lib$lib" if $no_prefix eq $lib;
-
- return ( $lib, $no_prefix ) if $GC;
- return ( $no_prefix, $lib );
-}
-
-sub _win32_attach_extensions {
- my ( $lib, $extensions ) = @_;
- return map _win32_try_attach_extension( $lib, $_ ), @{$extensions};
+ warn "Result: $lib\n" if $verbose;
+ wantarray ? ($lib, '', $lib, '', ($give_libs ? \@libs : ())) : $lib;
}
-sub _win32_try_attach_extension {
- my ( $lib, $extension ) = @_;
-
- return $lib if $lib =~ /\Q$extension\E$/i;
- return "$lib$extension";
-}
-
-sub _win32_lib_extensions {
- my @extensions;
- push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'};
- push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions;
- push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions;
- return \@extensions;
-}
-
-sub _debug {
- my ( $message, $verbose ) = @_;
- return if !$verbose;
- warn $message;
- return;
-}
sub _vms_ext {
- my ( $self, $potential_libs, $verbose, $give_libs ) = @_;
- $verbose ||= 0;
-
- my ( @crtls, $crtlstr );
- @crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' );
- push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} );
- push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} );
-
- # In general, we pass through the basic libraries from %Config unchanged.
- # The one exception is that if we're building in the Perl source tree, and
- # a library spec could be resolved via a logical name, we go to some trouble
- # to insure that the copy in the local tree is used, rather than one to
- # which a system-wide logical may point.
- if ( $self->{PERL_SRC} ) {
- my ( $locspec, $type );
- foreach my $lib ( @crtls ) {
- if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) {
- if ( lc $type eq '/share' ) { $locspec .= $Config{'exe_ext'}; }
- elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; }
- else { $locspec .= $Config{'obj_ext'}; }
- $locspec = $self->catfile( $self->{PERL_SRC}, $locspec );
- $lib = "$locspec$type" if -e $locspec;
- }
- }
+ my($self, $potential_libs, $verbose, $give_libs) = @_;
+ $verbose ||= 0;
+
+ my(@crtls,$crtlstr);
+ @crtls = ( ($Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+ # a library spec could be resolved via a logical name, we go to some trouble
+ # to insure that the copy in the local tree is used, rather than one to
+ # which a system-wide logical may point.
+ if ($self->{PERL_SRC}) {
+ my($locspec,$type);
+ foreach my $lib (@crtls) {
+ if (($locspec,$type) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i) {
+ if (lc $type eq '/share') { $locspec .= $Config{'exe_ext'}; }
+ elsif (lc $type eq '/library') { $locspec .= $Config{'lib_ext'}; }
+ else { $locspec .= $Config{'obj_ext'}; }
+ $locspec = $self->catfile($self->{PERL_SRC},$locspec);
+ $lib = "$locspec$type" if -e $locspec;
+ }
}
- $crtlstr = @crtls ? join( ' ', @crtls ) : '';
-
- unless ( $potential_libs ) {
- warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
- return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) );
+ }
+ $crtlstr = @crtls ? join(' ',@crtls) : '';
+
+ unless ($potential_libs) {
+ warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
+ return ('', '', $crtlstr, '', ($give_libs ? [] : ()));
+ }
+
+ my(%found,@fndlibs,$ldlib);
+ my $cwd = cwd();
+ my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'};
+ # List of common Unix library names and their VMS equivalents
+ # (VMS equivalent of '' indicates that the library is automatically
+ # searched by the linker, and should be skipped here.)
+ my(@flibs, %libs_seen);
+ my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '',
+ 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '',
+ 'socket' => '', 'X11' => 'DECW$XLIBSHR',
+ 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR',
+ 'Xmu' => 'DECW$XMULIBSHR');
+ if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; }
+
+ warn "Potential libraries are '$potential_libs'\n" if $verbose;
+
+ # First, sort out directories and library names in the input
+ my(@dirs, @libs);
+ foreach my $lib (split ' ',$potential_libs) {
+ push(@dirs,$1), next if $lib =~ /^-L(.*)/;
+ push(@dirs,$lib), next if $lib =~ /[:>\]]$/;
+ push(@dirs,$lib), next if -d $lib;
+ push(@libs,$1), next if $lib =~ /^-l(.*)/;
+ push(@libs,$lib);
+ }
+ push(@dirs,split(' ',$Config{'libpth'}));
+
+ # Now make sure we've got VMS-syntax absolute directory specs
+ # (We don't, however, check whether someone's hidden a relative
+ # path in a logical name.)
+ foreach my $dir (@dirs) {
+ unless (-d $dir) {
+ warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
+ $dir = '';
+ next;
+ }
+ warn "Resolving directory $dir\n" if $verbose;
+ if (File::Spec->file_name_is_absolute($dir)) {
+ $dir = $self->fixpath($dir,1);
+ }
+ else {
+ $dir = $self->catdir($cwd,$dir);
}
+ }
+ @dirs = grep { length($_) } @dirs;
+ unshift(@dirs,''); # Check each $lib without additions first
+
+ LIB: foreach my $lib (@libs) {
+ if (exists $libmap{$lib}) {
+ next unless length $libmap{$lib};
+ $lib = $libmap{$lib};
+ }
+
+ my(@variants,$cand);
+ my($ctype) = '';
- my ( %found, @fndlibs, $ldlib );
- my $cwd = cwd();
- my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' };
-
- # List of common Unix library names and their VMS equivalents
- # (VMS equivalent of '' indicates that the library is automatically
- # searched by the linker, and should be skipped here.)
- my ( @flibs, %libs_seen );
- my %libmap = (
- 'm' => '',
- 'f77' => '',
- 'F77' => '',
- 'V77' => '',
- 'c' => '',
- 'malloc' => '',
- 'crypt' => '',
- 'resolv' => '',
- 'c_s' => '',
- 'socket' => '',
- 'X11' => 'DECW$XLIBSHR',
- 'Xt' => 'DECW$XTSHR',
- 'Xm' => 'DECW$XMLIBSHR',
- 'Xmu' => 'DECW$XMULIBSHR'
- );
- if ( $Config{'vms_cc_type'} ne 'decc' ) { $libmap{'curses'} = 'VAXCCURSE'; }
-
- warn "Potential libraries are '$potential_libs'\n" if $verbose;
-
- # First, sort out directories and library names in the input
- my ( @dirs, @libs );
- foreach my $lib ( split ' ', $potential_libs ) {
- push( @dirs, $1 ), next if $lib =~ /^-L(.*)/;
- push( @dirs, $lib ), next if $lib =~ /[:>\]]$/;
- push( @dirs, $lib ), next if -d $lib;
- push( @libs, $1 ), next if $lib =~ /^-l(.*)/;
- push( @libs, $lib );
+ # If we don't have a file type, consider it a possibly abbreviated name and
+ # check for common variants. We try these first to grab libraries before
+ # a like-named executable image (e.g. -lperl resolves to perlshr.exe
+ # before perl.exe).
+ if ($lib !~ /\.[^:>\]]*$/) {
+ push(@variants,"${lib}shr","${lib}rtl","${lib}lib");
+ push(@variants,"lib$lib") if $lib !~ /[:>\]]/;
}
- push( @dirs, split( ' ', $Config{'libpth'} ) );
-
- # Now make sure we've got VMS-syntax absolute directory specs
- # (We don't, however, check whether someone's hidden a relative
- # path in a logical name.)
- foreach my $dir ( @dirs ) {
- unless ( -d $dir ) {
- warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
- $dir = '';
- next;
+ push(@variants,$lib);
+ warn "Looking for $lib\n" if $verbose;
+ foreach my $variant (@variants) {
+ my($fullname, $name);
+
+ foreach my $dir (@dirs) {
+ my($type);
+
+ $name = "$dir$variant";
+ warn "\tChecking $name\n" if $verbose > 2;
+ $fullname = VMS::Filespec::rmsexpand($name);
+ if (defined $fullname and -f $fullname) {
+ # It's got its own suffix, so we'll have to figure out the type
+ if ($fullname =~ /(?:$so|exe)$/i) { $type = 'SHR'; }
+ elsif ($fullname =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; }
+ elsif ($fullname =~ /(?:$obj_ext|obj)$/i) {
+ warn "Note (probably harmless): "
+ ."Plain object file $fullname found in library list\n";
+ $type = 'OBJ';
+ }
+ else {
+ warn "Note (probably harmless): "
+ ."Unknown library type for $fullname; assuming shared\n";
+ $type = 'SHR';
+ }
}
- warn "Resolving directory $dir\n" if $verbose;
- if ( File::Spec->file_name_is_absolute( $dir ) ) {
- $dir = $self->fixpath( $dir, 1 );
+ elsif (-f ($fullname = VMS::Filespec::rmsexpand($name,$so)) or
+ -f ($fullname = VMS::Filespec::rmsexpand($name,'.exe'))) {
+ $type = 'SHR';
+ $name = $fullname unless $fullname =~ /exe;?\d*$/i;
}
- else {
- $dir = $self->catdir( $cwd, $dir );
+ elsif (not length($ctype) and # If we've got a lib already,
+ # don't bother
+ ( -f ($fullname = VMS::Filespec::rmsexpand($name,$lib_ext)) or
+ -f ($fullname = VMS::Filespec::rmsexpand($name,'.olb')))) {
+ $type = 'OLB';
+ $name = $fullname unless $fullname =~ /olb;?\d*$/i;
}
- }
- @dirs = grep { length( $_ ) } @dirs;
- unshift( @dirs, '' ); # Check each $lib without additions first
-
- LIB: foreach my $lib ( @libs ) {
- if ( exists $libmap{$lib} ) {
- next unless length $libmap{$lib};
- $lib = $libmap{$lib};
+ elsif (not length($ctype) and # If we've got a lib already,
+ # don't bother
+ ( -f ($fullname = VMS::Filespec::rmsexpand($name,$obj_ext)) or
+ -f ($fullname = VMS::Filespec::rmsexpand($name,'.obj')))) {
+ warn "Note (probably harmless): "
+ ."Plain object file $fullname found in library list\n";
+ $type = 'OBJ';
+ $name = $fullname unless $fullname =~ /obj;?\d*$/i;
}
-
- my ( @variants, $cand );
- my ( $ctype ) = '';
-
- # If we don't have a file type, consider it a possibly abbreviated name and
- # check for common variants. We try these first to grab libraries before
- # a like-named executable image (e.g. -lperl resolves to perlshr.exe
- # before perl.exe).
- if ( $lib !~ /\.[^:>\]]*$/ ) {
- push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" );
- push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/;
- }
- push( @variants, $lib );
- warn "Looking for $lib\n" if $verbose;
- foreach my $variant ( @variants ) {
- my ( $fullname, $name );
-
- foreach my $dir ( @dirs ) {
- my ( $type );
-
- $name = "$dir$variant";
- warn "\tChecking $name\n" if $verbose > 2;
- $fullname = VMS::Filespec::rmsexpand( $name );
- if ( defined $fullname and -f $fullname ) {
-
- # It's got its own suffix, so we'll have to figure out the type
- if ( $fullname =~ /(?:$so|exe)$/i ) { $type = 'SHR'; }
- elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; }
- elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) {
- warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
- $type = 'OBJ';
- }
- else {
- warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n";
- $type = 'SHR';
- }
- }
- elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) )
- or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) )
- {
- $type = 'SHR';
- $name = $fullname unless $fullname =~ /exe;?\d*$/i;
- }
- elsif (
- not length( $ctype ) and # If we've got a lib already,
- # don't bother
- ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) )
- )
- {
- $type = 'OLB';
- $name = $fullname unless $fullname =~ /olb;?\d*$/i;
- }
- elsif (
- not length( $ctype ) and # If we've got a lib already,
- # don't bother
- ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) )
- )
- {
- warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n";
- $type = 'OBJ';
- $name = $fullname unless $fullname =~ /obj;?\d*$/i;
- }
- if ( defined $type ) {
- $ctype = $type;
- $cand = $name;
- last if $ctype eq 'SHR';
- }
- }
- if ( $ctype ) {
-
- # This has to precede any other CRTLs, so just make it first
- if ( $cand eq 'VAXCCURSE' ) { unshift @{ $found{$ctype} }, $cand; }
- else { push @{ $found{$ctype} }, $cand; }
- warn "\tFound as $cand (really $fullname), type $ctype\n"
- if $verbose > 1;
- push @flibs, $name unless $libs_seen{$fullname}++;
- next LIB;
- }
+ if (defined $type) {
+ $ctype = $type; $cand = $name;
+ last if $ctype eq 'SHR';
}
- warn "Warning (mostly harmless): " . "No library found for $lib\n";
+ }
+ if ($ctype) {
+ # This has to precede any other CRTLs, so just make it first
+ if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; }
+ else { push @{$found{$ctype}}, $cand; }
+ warn "\tFound as $cand (really $fullname), type $ctype\n"
+ if $verbose > 1;
+ push @flibs, $name unless $libs_seen{$fullname}++;
+ next LIB;
+ }
}
-
- push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ};
- push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB};
- push @fndlibs, map { "$_/Share" } @{ $found{SHR} } if exists $found{SHR};
- my $lib = join( ' ', @fndlibs );
-
- $ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
- warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
- wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib;
+ warn "Note (probably harmless): "
+ ."No library found for $lib\n";
+ }
+
+ push @fndlibs, @{$found{OBJ}} if exists $found{OBJ};
+ push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB};
+ push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR};
+ my $lib = join(' ',@fndlibs);
+
+ $ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
+ warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
+ wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib;
}
1;
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm
index a34015f94d1..eac5f483494 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm
@@ -3,7 +3,7 @@ package ExtUtils::MM;
use strict;
use ExtUtils::MakeMaker::Config;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm
index 7c600a6c2dc..5179be4bc2a 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm
@@ -1,7 +1,7 @@
package ExtUtils::MM_AIX;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm
index 060ce36837b..0b7c8db9225 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm
@@ -26,7 +26,7 @@ require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '6.98';
+our $VERSION = '6.56';
=item os_flavor
@@ -48,7 +48,7 @@ libperl.a equivalent to be linked to dynamic extensions.
sub init_linker {
my($self) = shift;
- $self->{PERL_ARCHIVE} ||=
+ $self->{PERL_ARCHIVE} ||=
File::Spec->catdir('$(PERL_INC)',$Config{libperl});
$self->{PERL_ARCHIVE_AFTER} ||= '';
$self->{EXPORT_LIST} ||= '';
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm
index d8f3e3a88fa..394fbc68a75 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm
@@ -9,7 +9,7 @@ require ExtUtils::MM_Unix;
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
-our $VERSION = '6.98';
+our $VERSION = '6.56';
=head1 NAME
@@ -90,7 +90,7 @@ sub init_linker {
}
$self->{PERL_ARCHIVE} = $libperl;
} else {
- $self->{PERL_ARCHIVE} =
+ $self->{PERL_ARCHIVE} =
'$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
}
@@ -100,55 +100,20 @@ sub init_linker {
=item maybe_command
-Determine whether a file is native to Cygwin by checking whether it
-resides inside the Cygwin installation (using Windows paths). If so,
-use C<ExtUtils::MM_Unix> to determine if it may be a command.
-Otherwise use the tests from C<ExtUtils::MM_Win32>.
+If our path begins with F</cygdrive/> then we use C<ExtUtils::MM_Win32>
+to determine if it may be a command. Otherwise we use the tests
+from C<ExtUtils::MM_Unix>.
=cut
sub maybe_command {
my ($self, $file) = @_;
- my $cygpath = Cygwin::posix_to_win_path('/', 1);
- my $filepath = Cygwin::posix_to_win_path($file, 1);
-
- return (substr($filepath,0,length($cygpath)) eq $cygpath)
- ? $self->SUPER::maybe_command($file) # Unix
- : ExtUtils::MM_Win32->maybe_command($file); # Win32
-}
-
-=item dynamic_lib
-
-Use the default to produce the *.dll's.
-But for new archdir dll's use the same rebase address if the old exists.
-
-=cut
-
-sub dynamic_lib {
- my($self, %attribs) = @_;
- my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs);
- my $ori = "$self->{INSTALLARCHLIB}/auto/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}";
- if (-e $ori) {
- my $imagebase = `/bin/objdump -p $ori | /bin/grep ImageBase | /bin/cut -c12-`;
- chomp $imagebase;
- if ($imagebase gt "40000000") {
- my $LDDLFLAGS = $self->{LDDLFLAGS};
- $LDDLFLAGS =~ s/-Wl,--enable-auto-image-base/-Wl,--image-base=0x$imagebase/;
- $s =~ s/ \$\(LDDLFLAGS\) / $LDDLFLAGS /m;
- }
+ if ($file =~ m{^/cygdrive/}i) {
+ return ExtUtils::MM_Win32->maybe_command($file);
}
- $s;
-}
-
-=item all_target
-
-Build man pages, too
-
-=cut
-sub all_target {
- ExtUtils::MM_Unix::all_target(shift);
+ return $self->SUPER::maybe_command($file);
}
=back
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm
index 4f52a9859db..fc0a7947235 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm
@@ -2,7 +2,7 @@ package ExtUtils::MM_DOS;
use strict;
-our $VERSION = '6.98';
+our $VERSION = 6.56;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm
index 861a544172a..1cb87c78815 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm
@@ -7,7 +7,7 @@ BEGIN {
our @ISA = qw( ExtUtils::MM_Unix );
}
-our $VERSION = '6.98';
+our $VERSION = '6.56';
=head1 NAME
@@ -20,7 +20,7 @@ ExtUtils::MM_Darwin - special behaviors for OS X
=head1 DESCRIPTION
-See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documentation on the
+See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documention on the
methods overridden here.
=head2 Overriden Methods
@@ -33,14 +33,14 @@ Turn off Apple tar's tendency to copy resource forks as "._foo" files.
sub init_dist {
my $self = shift;
-
+
# Thank you, Apple, for breaking tar and then breaking the work around.
# 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants
# COPYFILE_DISABLE. I'm not going to push my luck and instead just
# set both.
- $self->{TAR} ||=
+ $self->{TAR} ||=
'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';
-
+
$self->SUPER::init_dist(@_);
}
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm
index cd3a12a38c0..cfc82051e1b 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm
@@ -2,7 +2,7 @@ package ExtUtils::MM_MacOS;
use strict;
-our $VERSION = '6.98';
+our $VERSION = 6.56;
sub new {
die <<'UNSUPPORTED';
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm
index f6b0b5bd3a7..0c8f6c0affb 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm
@@ -16,13 +16,13 @@ the semantics.
=over
-=cut
+=cut
use strict;
use ExtUtils::MakeMaker::Config;
use File::Basename;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
@@ -66,7 +66,7 @@ sub init_platform {
# To get Win32's setup.
$self->SUPER::init_platform;
- # incpath is copied to makefile var INCLUDE in constants sub, here just
+ # incpath is copied to makefile var INCLUDE in constants sub, here just
# make it empty
my $libpth = $Config{'libpth'};
$libpth =~ s( )(;);
@@ -78,7 +78,7 @@ sub init_platform {
if($self->{'base_import'}) {
$self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'};
}
-
+
$self->{'NLM_VERSION'} = $Config{'nlm_version'};
$self->{'MPKTOOL'} = $Config{'mpktool'};
$self->{'TOOLPATH'} = $Config{'toolpath'};
@@ -110,7 +110,7 @@ sub platform_constants {
# Setup Win32's constants.
$make_frag .= $self->SUPER::platform_constants;
- foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
+ foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH
MM_NW5_VERSION
))
@@ -231,7 +231,7 @@ MAKE_FRAG
# Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
if($self->{NLM_SHORT_NAME}) {
- # In case of nlms with names exceeding 8 chars, build nlm in the
+ # In case of nlms with names exceeding 8 chars, build nlm in the
# current dir, rename and move to auto\lib.
$m .= q{ -o $(NLM_SHORT_NAME).$(DLEXT)}
} else {
@@ -245,7 +245,7 @@ MAKE_FRAG
if($self->{NLM_SHORT_NAME}) {
$m .= <<'MAKE_FRAG';
- if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT)
+ if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT)
move $(NLM_SHORT_NAME).$(DLEXT) $(INST_AUTODIR)
MAKE_FRAG
}
@@ -264,6 +264,6 @@ __END__
=back
-=cut
+=cut
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm
index 52bc4d1f108..680502baf24 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm
@@ -5,7 +5,7 @@ use strict;
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@@ -81,12 +81,12 @@ $self->{BASEEXT}.def: Makefile.PL
}
close $imp or die "Can't close tmpimp.imp";
# print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
- system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
+ system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
and die "Cannot make import library: $!, \$?=$?";
# May be running under miniperl, so have no glob...
- eval { unlink <tmp_imp/*>; 1 } or system "rm tmp_imp/*";
- system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
- and die "Cannot extract import objects: $!, \$?=$?";
+ eval "unlink <tmp_imp/*>; 1" or system "rm tmp_imp/*";
+ system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
+ and die "Cannot extract import objects: $!, \$?=$?";
}
join('',@m);
}
@@ -95,7 +95,7 @@ sub static_lib {
my($self) = @_;
my $old = $self->ExtUtils::MM_Unix::static_lib();
return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
-
+
my @chunks = split /\n{2,}/, $old;
shift @chunks unless length $chunks[0]; # Empty lines at the start
$chunks[0] .= <<'EOC';
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm
index 7b74bf41d56..f78d5e8a9ee 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm
@@ -1,7 +1,7 @@
package ExtUtils::MM_QNX;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm
index 5b9730025fd..5adc46ea8d2 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm
@@ -1,7 +1,7 @@
package ExtUtils::MM_UWIN;
use strict;
-our $VERSION = '6.98';
+our $VERSION = 6.56;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm
index 331cbcd0fa0..2066d035976 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm
@@ -15,7 +15,7 @@ BEGIN {
use File::Basename;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@@ -120,10 +120,10 @@ sub guess_name {
if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
elsif (@pm) {
%xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic
- if (keys %xs) {
- foreach my $pm (@pm) {
- $defpm = $pm, last if exists $xs{$pm};
- }
+ if (keys %xs) {
+ foreach my $pm (@pm) {
+ $defpm = $pm, last if exists $xs{$pm};
+ }
}
}
}
@@ -134,13 +134,13 @@ sub guess_name {
last;
}
}
- print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
+ print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
"defaulting package name to $defname\n"
if eof($pm);
close $pm;
}
else {
- print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
+ print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
"defaulting package name to $defname\n";
}
$defname =~ s#[\d.\-_]+$##;
@@ -200,8 +200,8 @@ sub find_perl {
$inabs++ if $self->file_name_is_absolute($dir);
if ($inabs == 1) {
# We've covered relative dirs; everything else is an absolute
- # dir (probably an installed location). First, we'll try
- # potential command names, to see whether we can avoid a long
+ # dir (probably an installed location). First, we'll try
+ # potential command names, to see whether we can avoid a long
# MCR expression.
foreach my $name (@snames) {
push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
@@ -217,7 +217,7 @@ sub find_perl {
print "Checking $name\n" if $trace >= 2;
# If it looks like a potential command, try it without the MCR
if ($name =~ /^[\w\-\$]+$/) {
- open(my $tcf, ">", "temp_mmvms.com")
+ open(my $tcf, ">", "temp_mmvms.com")
or die('unable to open temp file');
print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
@@ -244,27 +244,10 @@ sub find_perl {
return "MCR $vmsfile";
}
}
- print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
0; # false and not empty
}
-=item _fixin_replace_shebang (override)
-
-Helper routine for MM->fixin(), overridden because there's no such thing as an
-actual shebang line that will be interpreted by the shell, so we just prepend
-$Config{startperl} and preserve the shebang line argument for any switches it
-may contain.
-
-=cut
-
-sub _fixin_replace_shebang {
- my ( $self, $file, $line ) = @_;
-
- my ( undef, $arg ) = split ' ', $line, 2;
-
- return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n";
-}
-
=item maybe_command (override)
Follows VMS naming conventions for executable files.
@@ -396,7 +379,7 @@ sub init_DEST {
=item init_DIRFILESEP
-No separator between a directory path and a filename on VMS.
+No seperator between a directory path and a filename on VMS.
=cut
@@ -438,29 +421,30 @@ sub init_main {
}
$self->{DEFINE} = '';
- if (@defs) {
- $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')';
+ if (@defs) {
+ $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')';
}
- if (@udefs) {
- $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')';
+ if (@udefs) {
+ $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')';
}
}
}
-=item init_tools (override)
+=item init_others (override)
-Provide VMS-specific forms of various utility commands.
+Provide VMS-specific forms of various utility commands, then hand
+off to the default MM_Unix method.
-Sets DEV_NULL to nothing because I don't know how to do it on VMS.
+DEV_NULL should probably be overriden with something.
-Changes EQUALIZE_TIMESTAMP to set revision date of target file to
+Also changes EQUALIZE_TIMESTAMP to set revision date of target file to
one second later than source file, since MMK interprets precisely
equal revision dates for a source and target file as a sign that the
target needs to be updated.
=cut
-sub init_tools {
+sub init_others {
my($self) = @_;
$self->{NOOP} = 'Continue';
@@ -487,26 +471,35 @@ sub init_tools {
$self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';
- $self->{MOD_INSTALL} ||=
+ $self->{MOD_INSTALL} ||=
$self->oneliner(<<'CODE', ['-MExtUtils::Install']);
install([ from_to => {split(' ', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
CODE
- $self->{UMASK_NULL} = '! ';
-
- $self->SUPER::init_tools;
+ $self->SUPER::init_others;
- # Use the default shell
$self->{SHELL} ||= 'Posix';
+ $self->{UMASK_NULL} = '! ';
+
# Redirection on VMS goes before the command, not after as on Unix.
# $(DEV_NULL) is used once and its not worth going nuts over making
# it work. However, Unix's DEV_NULL is quite wrong for VMS.
$self->{DEV_NULL} = '';
- return;
+ if ($self->{OBJECT} =~ /\s/) {
+ $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g;
+ $self->{OBJECT} = $self->wraplist(
+ map $self->fixpath($_,0), split /,?\s+/, $self->{OBJECT}
+ );
+ }
+
+ $self->{LDFROM} = $self->wraplist(
+ map $self->fixpath($_,0), split /,?\s+/, $self->{LDFROM}
+ );
}
+
=item init_platform (override)
Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.
@@ -578,11 +571,11 @@ sub constants {
# Cleanup paths for directories in MMS macros.
foreach my $macro ( qw [
- INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
+ INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
PERL_LIB PERL_ARCHLIB
PERL_INC PERL_SRC ],
(map { 'INSTALL'.$_ } $self->installvars)
- )
+ )
{
next unless defined $self->{$macro};
next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
@@ -590,8 +583,8 @@ sub constants {
}
# Cleanup paths for files in MMS macros.
- foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
- MAKE_APERL_FILE MYEXTLIB] )
+ foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
+ MAKE_APERL_FILE MYEXTLIB] )
{
next unless defined $self->{$macro};
$self->{$macro} = $self->fixpath($self->{$macro},0);
@@ -600,37 +593,19 @@ sub constants {
# Fixup files for MMS macros
# XXX is this list complete?
for my $macro (qw/
- FULLEXT VERSION_FROM
+ FULLEXT VERSION_FROM OBJECT LDFROM
/ ) {
next unless defined $self->{$macro};
$self->{$macro} = $self->fixpath($self->{$macro},0);
}
- for my $macro (qw/
- OBJECT LDFROM
- / ) {
- next unless defined $self->{$macro};
-
- # Must expand macros before splitting on unescaped whitespace.
- $self->{$macro} = $self->eliminate_macros($self->{$macro});
- if ($self->{$macro} =~ /(?<!\^)\s/) {
- $self->{$macro} =~ s/(\\)?\n+\s+/ /g;
- $self->{$macro} = $self->wraplist(
- map $self->fixpath($_,0), split /,?(?<!\^)\s+/, $self->{$macro}
- );
- }
- else {
- $self->{$macro} = $self->fixpath($self->{$macro},0);
- }
- }
-
for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
# Where is the space coming from? --jhi
next unless $self ne " " && defined $self->{$macro};
my %tmp = ();
for my $key (keys %{$self->{$macro}}) {
- $tmp{$self->fixpath($key,0)} =
+ $tmp{$self->fixpath($key,0)} =
$self->fixpath($self->{$macro}{$key},0);
}
$self->{$macro} = \%tmp;
@@ -687,7 +662,7 @@ sub cflags {
my($name,$sys,@m);
( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
- print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
+ print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
" required to modify CC command for $self->{'BASEEXT'}\n"
if ($Config{$name});
@@ -843,7 +818,7 @@ VMSish defaults for some values.
COMPRESS compression command to gzip
use for tarfiles
- SUFFIX suffix to put on -gz
+ SUFFIX suffix to put on -gz
compressed files
SHAR shar command to use vms_share
@@ -930,7 +905,7 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o
=item dlsyms (override)
Create VMS linker options files specifying universal symbols for this
-extension's shareable image, and listing other shareable images or
+extension's shareable image, and listing other shareable images or
libraries to which it should be linked.
=cut
@@ -969,7 +944,7 @@ $(BASEEXT).opt : Makefile.PL
push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include=';
if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
- $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
+ $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
push @m, ($Config{d_vms_case_sensitive_symbols}
? uc($self->{BASEEXT}) :'$(BASEEXT)');
}
@@ -1080,7 +1055,7 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
} else {
push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
}
-
+
push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
foreach my $lib (split ' ', $self->{EXTRALIBS}) {
push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
@@ -1092,14 +1067,14 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
=item extra_clean_files
Clean up some OS specific files. Plus the temp file used to shorten
-a lot of commands. And the name mangler database.
+a lot of commands.
=cut
sub extra_clean_files {
return qw(
*.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
- .MM_Tmp cxx_repository
+ .MM_Tmp
);
}
@@ -1190,14 +1165,9 @@ doc__install : doc_site_install
# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
-];
- push @m,
-q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
-] unless $self->{NO_PACKLIST};
-
- push @m,
-q[ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
@@ -1209,14 +1179,9 @@ q[ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
# Likewise
pure_site_install ::
-];
- push @m,
-q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
-] unless $self->{NO_PACKLIST};
-
- push @m,
-q[ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
@@ -1227,14 +1192,9 @@ q[ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
$(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
pure_vendor_install ::
-];
- push @m,
-q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
+ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
$(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
-] unless $self->{NO_PACKLIST};
-
- push @m,
-q[ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
+ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp
$(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
@@ -1243,23 +1203,6 @@ q[ $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
$(NOECHO) $(MOD_INSTALL) <.MM_tmp
$(NOECHO) $(RM_F) .MM_tmp
-];
-
- push @m, q[
-# Ditto
-doc_perl_install ::
- $(NOECHO) $(NOOP)
-
-# And again
-doc_site_install ::
- $(NOECHO) $(NOOP)
-
-doc_vendor_install ::
- $(NOECHO) $(NOOP)
-
-] if $self->{NO_PERLLOCAL};
-
- push @m, q[
# Ditto
doc_perl_install ::
$(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
@@ -1286,7 +1229,7 @@ doc_vendor_install ::
$(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
$(NOECHO) $(RM_F) .MM_tmp
-] unless $self->{NO_PERLLOCAL};
+];
push @m, q[
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
@@ -1320,12 +1263,23 @@ sub perldepend {
my($self) = @_;
my(@m);
- if ($self->{OBJECT}) {
- # Need to add an object file dependency on the perl headers.
- # this is very important for XS modules in perl.git development.
-
- push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC)
- }
+ push @m, '
+$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h
+$(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h
+$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h
+$(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h
+$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h
+$(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h
+$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h
+$(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
+$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h
+$(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h
+$(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h
+$(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h
+$(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
+$(OBJECT) : $(PERL_INC)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h
+
+' if $self->{OBJECT};
if ($self->{PERL_SRC}) {
my(@macros);
@@ -1379,7 +1333,7 @@ our %olbs; # needs to be localized
sub makeaperl {
my($self, %attribs) = @_;
- my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
@attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
my(@m);
push @m, "
@@ -1460,7 +1414,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
# We trust that what has been handed in as argument will be buildable
$static = [] unless $static;
@olbs{@{$static}} = (1) x @{$static};
-
+
$extra = [] unless $extra && ref $extra eq 'ARRAY';
# Sort the object libraries in inverse order of
# filespec length to try to insure that dependent extensions
@@ -1524,7 +1478,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
if ($libperl) {
unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
- print "Warning: $libperl not found\n";
+ print STDOUT "Warning: $libperl not found\n";
undef $libperl;
}
}
@@ -1533,7 +1487,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
$libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
} elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
} else {
- print "Warning: $libperl not found
+ print STDOUT "Warning: $libperl not found
If you're going to build a static perl binary, make sure perl is installed
otherwise ignore this warning\n";
}
@@ -1653,32 +1607,32 @@ sub prefixify {
$rprefix = vmspath($rprefix) if $rprefix;
$sprefix = vmspath($sprefix) if $sprefix;
- $default = vmsify($default)
+ $default = vmsify($default)
unless $default =~ /\[.*\]/;
(my $var_no_install = $var) =~ s/^install//;
- my $path = $self->{uc $var} ||
- $ExtUtils::MM_Unix::Config_Override{lc $var} ||
+ my $path = $self->{uc $var} ||
+ $ExtUtils::MM_Unix::Config_Override{lc $var} ||
$Config{lc $var} || $Config{lc $var_no_install};
if( !$path ) {
- warn " no Config found for $var.\n" if $Verbose >= 2;
+ print STDERR " no Config found for $var.\n" if $Verbose >= 2;
$path = $self->_prefixify_default($rprefix, $default);
}
elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
# do nothing if there's no prefix or if its relative
}
elsif( $sprefix eq $rprefix ) {
- warn " no new prefix.\n" if $Verbose >= 2;
+ print STDERR " no new prefix.\n" if $Verbose >= 2;
}
else {
- warn " prefixify $var => $path\n" if $Verbose >= 2;
- warn " from $sprefix to $rprefix\n" if $Verbose >= 2;
+ print STDERR " prefixify $var => $path\n" if $Verbose >= 2;
+ print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2;
my($path_vol, $path_dirs) = $self->splitpath( $path );
if( $path_vol eq $Config{vms_prefix}.':' ) {
- warn " $Config{vms_prefix}: seen\n" if $Verbose >= 2;
+ print STDERR " $Config{vms_prefix}: seen\n" if $Verbose >= 2;
$path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
$path = $self->_catprefix($rprefix, $path_dirs);
@@ -1696,14 +1650,14 @@ sub prefixify {
sub _prefixify_default {
my($self, $rprefix, $default) = @_;
- warn " cannot prefix, using default.\n" if $Verbose >= 2;
+ print STDERR " cannot prefix, using default.\n" if $Verbose >= 2;
if( !$default ) {
- warn "No default!\n" if $Verbose >= 1;
+ print STDERR "No default!\n" if $Verbose >= 1;
return;
}
if( !$rprefix ) {
- warn "No replacement prefix!\n" if $Verbose >= 1;
+ print STDERR "No replacement prefix!\n" if $Verbose >= 1;
return '';
}
@@ -1782,21 +1736,13 @@ native Write command instead. Besides, its faster.
=cut
sub echo {
- my($self, $text, $file, $opts) = @_;
-
- # Compatibility with old options
- if( !ref $opts ) {
- my $append = $opts;
- $opts = { append => $append || 0 };
- }
- my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write';
+ my($self, $text, $file, $appending) = @_;
+ $appending ||= 0;
- $opts->{allow_variables} = 0 unless defined $opts->{allow_variables};
-
- my $ql_opts = { allow_variables => $opts->{allow_variables} };
+ my $opencmd = $appending ? 'Open/Append' : 'Open/Write';
my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
- push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) }
+ push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) }
split /\n/, $text;
push @cmds, '$(NOECHO) Close MMECHOFILE';
return @cmds;
@@ -1808,49 +1754,14 @@ sub echo {
=cut
sub quote_literal {
- my($self, $text, $opts) = @_;
- $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
+ my($self, $text) = @_;
# I believe this is all we should need.
$text =~ s{"}{""}g;
- $text = $opts->{allow_variables}
- ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
-
return qq{"$text"};
}
-=item escape_dollarsigns
-
-Quote, don't escape.
-
-=cut
-
-sub escape_dollarsigns {
- my($self, $text) = @_;
-
- # Quote dollar signs which are not starting a variable
- $text =~ s{\$ (?!\() }{"\$"}gx;
-
- return $text;
-}
-
-
-=item escape_all_dollarsigns
-
-Quote, don't escape.
-
-=cut
-
-sub escape_all_dollarsigns {
- my($self, $text) = @_;
-
- # Quote dollar signs
- $text =~ s{\$}{"\$\"}gx;
-
- return $text;
-}
-
=item escape_newlines
=cut
@@ -1963,7 +1874,7 @@ sub eliminate_macros {
my($head,$macro,$tail);
# perform m##g in scalar context so it acts as an iterator
- while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
+ while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
if (defined $self->{$2}) {
($head,$macro,$tail) = ($1,$2,$3);
if (ref $self->{$macro}) {
@@ -2019,7 +1930,7 @@ sub fixpath {
split /[ \t]+/, $path;
}
- if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
+ if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm
index 648ba5401b6..1814a1dae4c 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm
@@ -1,7 +1,7 @@
package ExtUtils::MM_VOS;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm
index e056d2eacc5..19e462de593 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm
@@ -17,7 +17,7 @@ See ExtUtils::MM_Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
-=cut
+=cut
use ExtUtils::MakeMaker::Config;
use File::Basename;
@@ -27,21 +27,13 @@ use ExtUtils::MakeMaker qw( neatvalue );
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '6.98';
+our $VERSION = '6.56';
$ENV{EMXSHELL} = 'sh'; # to run `commands`
-my ( $BORLAND, $GCC, $DLLTOOL ) = _identify_compiler_environment( \%Config );
-
-sub _identify_compiler_environment {
- my ( $config ) = @_;
-
- my $BORLAND = $config->{cc} =~ /^bcc/i ? 1 : 0;
- my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0;
- my $DLLTOOL = $config->{dlltool} || 'dlltool';
-
- return ( $BORLAND, $GCC, $DLLTOOL );
-}
+my $BORLAND = $Config{'cc'} =~ /^bcc/i ? 1 : 0;
+my $GCC = $Config{'cc'} =~ /\bgcc$/i ? 1 : 0;
+my $DLLTOOL = $Config{'dlltool'} || 'dlltool';
=head2 Overridden methods
@@ -141,34 +133,13 @@ sub init_DIRFILESEP {
: '\\';
}
-=item init_tools
-
-Override some of the slower, portable commands with Windows specific ones.
+=item B<init_others>
-=cut
+Override some of the Unix specific commands with portable
+ExtUtils::Command ones.
-sub init_tools {
- my ($self) = @_;
-
- $self->{NOOP} ||= 'rem';
- $self->{DEV_NULL} ||= '> NUL';
-
- $self->{FIXIN} ||= $self->{PERL_CORE} ?
- "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
- 'pl2bat.bat';
-
- $self->SUPER::init_tools;
-
- # Setting SHELL from $Config{sh} can break dmake. Its ok without it.
- delete $self->{SHELL};
-
- return;
-}
-
-
-=item init_others
-
-Override the default link and compile tools.
+Also provide defaults for LD and AR in case the %Config values aren't
+set.
LDLOADLIBS's default is changed to $Config{libs}.
@@ -177,13 +148,23 @@ Adjustments are made for Borland's quirks needing -L to come first.
=cut
sub init_others {
- my $self = shift;
+ my ($self) = @_;
+
+ $self->{NOOP} ||= 'rem';
+ $self->{DEV_NULL} ||= '> NUL';
+
+ $self->{FIXIN} ||= $self->{PERL_CORE} ?
+ "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
+ 'pl2bat.bat';
$self->{LD} ||= 'link';
$self->{AR} ||= 'lib';
$self->SUPER::init_others;
+ # Setting SHELL from $Config{sh} can break dmake. Its ok without it.
+ delete $self->{SHELL};
+
$self->{LDLOADLIBS} ||= $Config{libs};
# -Lfoo must come first for Borland, so we put it in LDDLFLAGS
if ($BORLAND) {
@@ -198,7 +179,7 @@ sub init_others {
$self->{LDDLFLAGS} .= " $libpath";
}
- return;
+ return 1;
}
@@ -214,8 +195,6 @@ sub init_platform {
my($self) = shift;
$self->{MM_Win32_VERSION} = $VERSION;
-
- return;
}
sub platform_constants {
@@ -232,36 +211,6 @@ sub platform_constants {
}
-=item constants
-
-Add MAXLINELENGTH for dmake before all the constants are output.
-
-=cut
-
-sub constants {
- my $self = shift;
-
- my $make_text = $self->SUPER::constants;
- return $make_text unless $self->is_make_type('dmake');
-
- # dmake won't read any single "line" (even those with escaped newlines)
- # larger than a certain size which can be as small as 8k. PM_TO_BLIB
- # on large modules like DateTime::TimeZone can create lines over 32k.
- # So we'll crank it up to a <ironic>WHOPPING</ironic> 64k.
- #
- # This has to come here before all the constants and not in
- # platform_constants which is after constants.
- my $size = $self->{MAXLINELENGTH} || 800000;
- my $prefix = qq{
-# Get dmake to read long commands like PM_TO_BLIB
-MAXLINELENGTH = $size
-
-};
-
- return $prefix . $make_text;
-}
-
-
=item special_targets
Add .USESHELL target for dmake.
@@ -340,6 +289,17 @@ sub dynamic_lib {
my($ldfrom) = '$(LDFROM)';
my(@m);
+# one thing for GCC/Mingw32:
+# we try to overcome non-relocateable-DLL problems by generating
+# a (hopefully unique) image-base from the dll's name
+# -- BKS, 10-19-1999
+ if ($GCC) {
+ my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
+ $dllname =~ /(....)(.{0,4})/;
+ my $baseaddr = unpack("n", $1 ^ $2);
+ $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
+ }
+
push(@m,'
# This section creates the dynamically loadable $(INST_DYNAMIC)
# from $(OBJECT) and possibly $(MYEXTLIB).
@@ -349,7 +309,7 @@ INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
');
if ($GCC) {
- push(@m,
+ push(@m,
q{ }.$DLLTOOL.q{ --def $(EXPORT_LIST) --output-exp dll.exp
$(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
}.$DLLTOOL.q{ --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
@@ -496,34 +456,22 @@ sub oneliner {
sub quote_literal {
- my($self, $text, $opts) = @_;
- $opts->{allow_variables} = 1 unless defined $opts->{allow_variables};
-
- # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP
-
- # Apply the Microsoft C/C++ parsing rules
- $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\"
- $text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\"
- $text =~ s{(?<!\\)"}{\\"}g; # " -> \"
- $text = qq{"$text"} if $text =~ /[ \t]/;
+ my($self, $text) = @_;
- # Apply the Command Prompt parsing rules (cmd.exe)
- my @text = split /("[^"]*")/, $text;
- # We should also escape parentheses, but it breaks one-liners containing
- # $(MACRO)s in makefiles.
- s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text;
- $text = join('', @text);
+ # I don't know if this is correct, but it seems to work on
+ # Win98's command.com
+ $text =~ s{"}{\\"}g;
- # dmake expands {{ to { and }} to }.
+ # dmake eats '{' inside double quotes and leaves alone { outside double
+ # quotes; however it transforms {{ into { either inside and outside double
+ # quotes. It also translates }} into }. The escaping below is not
+ # 100% correct.
if( $self->is_make_type('dmake') ) {
$text =~ s/{/{{/g;
- $text =~ s/}/}}/g;
+ $text =~ s/}}/}}}/g;
}
- $text = $opts->{allow_variables}
- ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text);
-
- return $text;
+ return qq{"$text"};
}
@@ -632,6 +580,6 @@ __END__
=back
-=cut
+=cut
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm
index 9c7958058c2..c47147695e8 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm
@@ -2,7 +2,7 @@ package ExtUtils::MM_Win95;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
@@ -62,7 +62,7 @@ sub xs_cpp {
';
}
-=item xs_o
+=item xs_o
The && problem.
@@ -116,7 +116,7 @@ Currently maintained by Michael G Schwern C<schwern@pobox.com>.
Send patches and ideas to C<makemaker@perl.org>.
-See https://metacpan.org/release/ExtUtils-MakeMaker.
+See http://www.makemaker.org.
=cut
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm
index 37f0e9e29d1..bed177d210a 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm
@@ -3,7 +3,7 @@ package ExtUtils::MY;
use strict;
require ExtUtils::MM;
-our $VERSION = '6.98';
+our $VERSION = 6.56;
our @ISA = qw(ExtUtils::MM);
{
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm
index 5c703f08080..38b60affdda 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm
@@ -2,7 +2,7 @@ package ExtUtils::MakeMaker::Config;
use strict;
-our $VERSION = '6.98';
+our $VERSION = '6.56';
use Config ();
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod
index 5d43d40c39f..8ad72649b1a 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod
@@ -1,6 +1,6 @@
package ExtUtils::MakeMaker::Tutorial;
-our $VERSION = '6.98';
+our $VERSION = 0.02;
=head1 NAME
@@ -19,7 +19,7 @@ ExtUtils::MakeMaker::Tutorial - Writing a module with MakeMaker
=head1 DESCRIPTION
This is a short tutorial on writing a simple module with MakeMaker.
-It's really not that hard.
+Its really not that hard.
=head2 The Mantra
@@ -95,8 +95,8 @@ See L<ExtUtils::Manifest> for more details.
=item lib/
-This is the directory where the .pm and .pod files you wish to have
-installed go. They are laid out according to namespace. So Foo::Bar
+This is the directory where your .pm and .pod files you wish to have
+installed go. They are layed out according to namespace. So Foo::Bar
is F<lib/Foo/Bar.pm>.
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm
index bb85e85cec2..707466a98dd 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm
@@ -3,7 +3,7 @@ package ExtUtils::Mkbootstrap;
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
-our $VERSION = '6.98';
+our $VERSION = '6.56';
require Exporter;
our @ISA = ('Exporter');
@@ -18,7 +18,7 @@ sub Mkbootstrap {
my($baseext, @bsloadlibs)=@_;
@bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
- print " bsloadlibs=@bsloadlibs\n" if $Verbose;
+ print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
# We need DynaLoader here because we and/or the *_BS file may
# call dl_findfile(). We don't say `use' here because when
@@ -50,8 +50,8 @@ sub Mkbootstrap {
if (@all){
open my $bs, ">", "$baseext.bs"
or die "Unable to open $baseext.bs: $!";
- print "Writing $baseext.bs\n";
- print " containing: @all" if $Verbose;
+ print STDOUT "Writing $baseext.bs\n";
+ print STDOUT " containing: @all" if $Verbose;
print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n";
print $bs "# Do not edit this file, changes will be lost.\n";
print $bs "# This file was automatically generated by the\n";
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm
index 176faf17529..962c67fd57f 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm
@@ -10,7 +10,7 @@ use Config;
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
-our $VERSION = '6.98';
+our $VERSION = '6.56';
sub Mksymlists {
my(%spec) = @_;
@@ -27,7 +27,7 @@ sub Mksymlists {
unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or
@{$spec{FUNCLIST}});
if (defined $spec{DL_FUNCS}) {
- foreach my $package (sort keys %{$spec{DL_FUNCS}}) {
+ foreach my $package (keys %{$spec{DL_FUNCS}}) {
my($packprefix,$bootseen);
($packprefix = $package) =~ s/\W/_/g;
foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) {
@@ -86,7 +86,7 @@ sub _write_os2 {
my $distname = $data->{DISTNAME} || $data->{NAME};
$distname = "Distribution $distname";
my $patchlevel = " pl$Config{perl_patchlevel}" || '';
- my $comment = sprintf "Perl (v%s%s%s) module %s",
+ my $comment = sprintf "Perl (v%s%s%s) module %s",
$Config::Config{version}, $threaded, $patchlevel, $data->{NAME};
chomp $comment;
if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') {
@@ -106,20 +106,14 @@ sub _write_os2 {
print $def "EXPORTS\n ";
print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
- _print_imports($def, $data);
- close $def;
-}
-
-sub _print_imports {
- my ($def, $data)= @_;
- my $imports= $data->{IMPORTS}
- or return;
- if ( keys %$imports ) {
+ if (%{$data->{IMPORTS}}) {
print $def "IMPORTS\n";
- foreach my $name (sort keys %$imports) {
- print $def " $name=$imports->{$name}\n";
+ my ($name, $exp);
+ while (($name, $exp)= each %{$data->{IMPORTS}}) {
+ print $def " $name=$exp\n";
}
}
+ close $def;
}
sub _write_win32 {
@@ -156,7 +150,13 @@ sub _write_win32 {
}
}
print $def join("\n ",@syms, "\n") if @syms;
- _print_imports($def, $data);
+ if (%{$data->{IMPORTS}}) {
+ print $def "IMPORTS\n";
+ my ($name, $exp);
+ while (($name, $exp)= each %{$data->{IMPORTS}}) {
+ print $def " $name=$exp\n";
+ }
+ }
close $def;
}
@@ -197,7 +197,7 @@ sub _write_vms {
if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; }
}
-
+
close $opt;
}
@@ -212,10 +212,10 @@ ExtUtils::Mksymlists - write linker options files for dynamic extension
=head1 SYNOPSIS
use ExtUtils::Mksymlists;
- Mksymlists( NAME => $name ,
+ Mksymlists({ NAME => $name ,
DL_VARS => [ $var1, $var2, $var3 ],
DL_FUNCS => { $pkg1 => [ $func1, $func2 ],
- $pkg2 => [ $func3 ] );
+ $pkg2 => [ $func3 ] });
=head1 DESCRIPTION
@@ -281,9 +281,9 @@ generation of the bootstrap function for the package. To still create
the bootstrap name you have to specify the package name in the
DL_FUNCS hash:
- Mksymlists( NAME => $name ,
+ Mksymlists({ NAME => $name ,
FUNCLIST => [ $func1, $func2 ],
- DL_FUNCS => { $pkg => [] } );
+ DL_FUNCS => { $pkg => [] } });
=item IMPORTS
diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm
index d8cd4bcb42a..fe01beb0e1e 100644
--- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm
+++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm
@@ -3,7 +3,7 @@ package ExtUtils::testlib;
use strict;
use warnings;
-our $VERSION = '6.98';
+our $VERSION = 6.56;
use Cwd;
use File::Spec;
@@ -11,7 +11,7 @@ use File::Spec;
# So the tests can chdir around and not break @INC.
# We use getcwd() because otherwise rel2abs will blow up under taint
# mode pre-5.8. We detaint is so @INC won't be tainted. This is
-# no worse, and probably better, than just shoving an untainted,
+# no worse, and probably better, than just shoving an untainted,
# relative "blib/lib" onto @INC.
my $cwd;
BEGIN {
diff --git a/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm b/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm
index 7d6a263e2bf..4aabc29be55 100644
--- a/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm
+++ b/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm
@@ -19,30 +19,27 @@ use Locale::Maketext::Simple Style => 'gettext';
use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
$BLACKLIST $METHOD_FAIL $VERSION $METHODS
- $FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4
+ $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
];
-$VERSION = '0.48';
+$VERSION = '0.24';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
$USER_AGENT = "File::Fetch/$VERSION";
$BLACKLIST = [qw|ftp|];
-push @$BLACKLIST, qw|lftp| if $^O eq 'dragonfly';
$METHOD_FAIL = { };
$FTP_PASSIVE = 1;
$TIMEOUT = 0;
$DEBUG = 0;
$WARN = 1;
-$FORCEIPV4 = 0;
### methods available to fetch the file depending on the scheme
$METHODS = {
- http => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ],
- ftp => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ],
+ http => [ qw|lwp wget curl lftp lynx iosock| ],
+ ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
file => [ qw|lwp lftp file| ],
- rsync => [ qw|rsync| ],
- git => [ qw|git| ],
+ rsync => [ qw|rsync| ]
};
### silly warnings ###
@@ -53,11 +50,11 @@ local $Module::Load::Conditional::VERBOSE = 0;
### see what OS we are on, important for file:// uris ###
use constant ON_WIN => ($^O eq 'MSWin32');
-use constant ON_VMS => ($^O eq 'VMS');
+use constant ON_VMS => ($^O eq 'VMS');
use constant ON_UNIX => (!ON_WIN);
use constant HAS_VOL => (ON_WIN);
use constant HAS_SHARE => (ON_WIN);
-use constant HAS_FETCH => ( $^O =~ m!^(freebsd|netbsd|dragonfly)$! );
+
=pod
@@ -90,7 +87,7 @@ File::Fetch - A generic file fetching mechanism
File::Fetch is a generic file fetching mechanism.
It allows you to fetch any file pointed to by a C<ftp>, C<http>,
-C<file>, C<git> or C<rsync> uri by a number of different means.
+C<file>, or C<rsync> uri by a number of different means.
See the C<HOW IT WORKS> section further down for details.
@@ -110,7 +107,7 @@ The scheme from the uri (like 'file', 'http', etc)
=item $ff->host
-The hostname in the uri. Will be empty if host was originally
+The hostname in the uri. Will be empty if host was originally
'localhost' for a 'file://' url.
=item $ff->vol
@@ -120,8 +117,8 @@ of a file:// is considered to the be volume specification for the file.
Thus on Win32 this routine returns the volume, on other operating
systems this returns nothing.
-On Windows this value may be empty if the uri is to a network share, in
-which case the 'share' property will be defined. Additionally, volume
+On Windows this value may be empty if the uri is to a network share, in
+which case the 'share' property will be defined. Additionally, volume
specifications that use '|' as ':' will be converted on read to use ':'.
On VMS, which has a volume concept, this field will be empty because VMS
@@ -130,7 +127,7 @@ information is transparently included.
=item $ff->share
-On systems with the concept of a network share (currently only Windows) returns
+On systems with the concept of a network share (currently only Windows) returns
the sharename from a file://// url. On other operating systems returns empty.
=item $ff->path
@@ -140,14 +137,7 @@ The path from the uri, will be at least a single '/'.
=item $ff->file
The name of the remote file. For the local file name, the
-result of $ff->output_file will be used.
-
-=item $ff->file_default
-
-The name of the default local file, that $ff->output_file falls back to if
-it would otherwise return no filename. For example when fetching a URI like
-http://www.abc.net.au/ the contents retrieved may be from a remote file called
-'index.html'. The default value of this attribute is literally 'file_default'.
+result of $ff->output_file will be used.
=cut
@@ -166,12 +156,10 @@ http://www.abc.net.au/ the contents retrieved may be from a remote file called
uri => { required => 1 },
vol => { default => '' }, # windows for file:// uris
share => { default => '' }, # windows for file:// uris
- file_default => { default => 'file_default' },
- tempdir_root => { required => 1 }, # Should be lazy-set at ->new()
_error_msg => { no_override => 1 },
_error_msg_long => { no_override => 1 },
};
-
+
for my $method ( keys %$Tmpl ) {
no strict 'refs';
*$method = sub {
@@ -180,28 +168,28 @@ http://www.abc.net.au/ the contents retrieved may be from a remote file called
return $self->{$method};
}
}
-
+
sub _create {
my $class = shift;
my %hash = @_;
-
+
my $args = check( $Tmpl, \%hash ) or return;
-
+
bless $args, $class;
-
+
if( lc($args->scheme) ne 'file' and not $args->host ) {
return $class->_error(loc(
"Hostname required when fetching from '%1'",$args->scheme));
}
-
- for (qw[path]) {
+
+ for (qw[path file]) {
unless( $args->$_() ) { # 5.5.x needs the ()
return $class->_error(loc("No '%1' specified",$_));
}
}
-
+
return $args;
- }
+ }
}
=item $ff->output_file
@@ -211,7 +199,7 @@ but any query parameters are stripped off. For example:
http://example.com/index.html?x=y
-would make the output file be C<index.html> rather than
+would make the output file be C<index.html> rather than
C<index.html?x=y>.
=back
@@ -221,49 +209,47 @@ C<index.html?x=y>.
sub output_file {
my $self = shift;
my $file = $self->file;
-
+
$file =~ s/\?.*$//g;
-
- $file ||= $self->file_default;
-
+
return $file;
}
### XXX do this or just point to URI::Escape?
# =head2 $esc_uri = $ff->escaped_uri
-#
+#
# =cut
-#
+#
# ### most of this is stolen straight from URI::escape
# { ### Build a char->hex map
# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
-#
+#
# sub escaped_uri {
# my $self = shift;
# my $uri = $self->uri;
-#
+#
# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
# $escapes{$1} || $self->_fail_hi($1)/ge;
-#
+#
# return $uri;
# }
-#
+#
# sub _fail_hi {
# my $self = shift;
# my $char = shift;
-#
+#
# $self->_error(loc(
-# "Can't escape '%1', try using the '%2' module instead",
+# "Can't escape '%1', try using the '%2' module instead",
# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
-# ));
+# ));
# }
-#
+#
# sub output_file {
-#
+#
# }
-#
-#
+#
+#
# }
=head1 METHODS
@@ -281,11 +267,9 @@ sub new {
my $class = shift;
my %hash = @_;
- my ($uri, $file_default, $tempdir_root);
+ my ($uri);
my $tmpl = {
- uri => { required => 1, store => \$uri },
- file_default => { required => 0, store => \$file_default },
- tempdir_root => { required => 0, store => \$tempdir_root },
+ uri => { required => 1, store => \$uri },
};
check( $tmpl, \%hash ) or return;
@@ -293,10 +277,6 @@ sub new {
### parse the uri to usable parts ###
my $href = $class->_parse_uri( $uri ) or return;
- $href->{file_default} = $file_default if $file_default;
- $href->{tempdir_root} = File::Spec->rel2abs( $tempdir_root ) if $tempdir_root;
- $href->{tempdir_root} = File::Spec->rel2abs( Cwd::cwd ) if not $href->{tempdir_root};
-
### make it into a FFI object ###
my $ff = $class->_create( %$href ) or return;
@@ -320,22 +300,22 @@ sub new {
###
### In the case of file:// urls there maybe be additional fields
###
-### For systems with volume specifications such as Win32 there will be
+### For systems with volume specifications such as Win32 there will be
### a volume specifier provided in the 'vol' field.
###
### 'vol' => 'volumename'
###
### For windows file shares there may be a 'share' key specified
###
-### 'share' => 'sharename'
+### 'share' => 'sharename'
###
-### Note that the rules of what a file:// url means vary by the operating system
+### Note that the rules of what a file:// url means vary by the operating system
### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
-### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
+### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
### not '/foo/bar.txt'
###
-### Similarly if the host interpreting the url is VMS then
-### file:///disk$user/my/notes/note12345.txt' means
+### Similarly if the host interpreting the url is VMS then
+### file:///disk$user/my/notes/note12345.txt' means
### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
### if it is unix where it means /disk$user/my/notes/note12345.txt'.
### Except for some cases in the File::Spec methods, Perl on VMS will generally
@@ -361,7 +341,7 @@ sub _parse_uri {
### And wikipedia for more on windows file:// urls
### http://en.wikipedia.org/wiki/File://
if( $href->{scheme} eq 'file' ) {
-
+
my @parts = split '/',$uri;
### file://hostname/...
@@ -370,36 +350,36 @@ sub _parse_uri {
$href->{host} = $parts[0] || '';
### index in @parts where the path components begin;
- my $index = 1;
+ my $index = 1;
- ### file:////hostname/sharename/blah.txt
+ ### file:////hostname/sharename/blah.txt
if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
-
+
$href->{host} = $parts[2] || ''; # avoid warnings
- $href->{share} = $parts[3] || ''; # avoid warnings
+ $href->{share} = $parts[3] || ''; # avoid warnings
$index = 4 # index after the share
### file:///D|/blah.txt
### file:///D:/blah.txt
} elsif (HAS_VOL) {
-
+
### this code comes from dmq's patch, but:
### XXX if volume is empty, wouldn't that be an error? --kane
- ### if so, our file://localhost test needs to be fixed as wel
+ ### if so, our file://localhost test needs to be fixed as wel
$href->{vol} = $parts[1] || '';
### correct D| style colume descriptors
$href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
$index = 2; # index after the volume
- }
+ }
### rebuild the path from the leftover parts;
$href->{path} = join '/', '', splice( @parts, $index, $#parts );
} else {
- ### using anything but qw() in hash slices may produce warnings
+ ### using anything but qw() in hash slices may produce warnings
### in older perls :-(
@{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
}
@@ -410,7 +390,7 @@ sub _parse_uri {
$href->{file} = $parts[2];
}
- ### host will be empty if the target was 'localhost' and the
+ ### host will be empty if the target was 'localhost' and the
### scheme was 'file'
$href->{host} = '' if ($href->{host} eq 'localhost') and
($href->{scheme} eq 'file');
@@ -422,7 +402,7 @@ sub _parse_uri {
Fetches the file you requested and returns the full path to the file.
-By default it writes to C<cwd()>, but you can override that by specifying
+By default it writes to C<cwd()>, but you can override that by specifying
the C<to> argument:
### file fetch to /tmp, full path to the file in $where
@@ -451,7 +431,7 @@ sub fetch {
my ($to, $fh);
### you want us to slurp the contents
if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
- $to = tempdir( 'FileFetch.XXXXXX', DIR => $self->tempdir_root, CLEANUP => 1 );
+ $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 );
### plain old fetch
} else {
@@ -463,7 +443,7 @@ sub fetch {
### create the path if it doesn't exist yet ###
unless( -d $to ) {
eval { mkpath( $to ) };
-
+
return $self->_error(loc("Could not create path '%1'",$to)) if $@;
}
}
@@ -473,9 +453,9 @@ sub fetch {
### we dont use catfile on win32 because if we are using a cygwin tool
### under cmd.exe they wont understand windows style separators.
- my $out_to = ON_WIN ? $to.'/'.$self->output_file
+ my $out_to = ON_WIN ? $to.'/'.$self->output_file
: File::Spec->catfile( $to, $self->output_file );
-
+
for my $method ( @{ $METHODS->{$self->scheme} } ) {
my $sub = '_'.$method.'_fetch';
@@ -493,13 +473,13 @@ sub fetch {
### there's serious issues with IPC::Run and quoting of command
### line arguments. using quotes in the wrong place breaks things,
- ### and in the case of say,
+ ### and in the case of say,
### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
### it doesn't matter how you quote, it always fails.
local $IPC::Cmd::USE_IPC_RUN = 0;
-
- if( my $file = $self->$sub(
+
+ if( my $file = $self->$sub(
to => $out_to
)){
@@ -516,18 +496,18 @@ sub fetch {
### slurp mode?
if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
-
+
### open the file
- open my $fh, "<$file" or do {
+ open my $fh, $file or do {
$self->_error(
loc("Could not open '%1': %2", $file, $!));
- return;
+ return;
};
-
+
### slurp
$$target = do { local $/; <$fh> };
-
- }
+
+ }
my $abs = File::Spec->rel2abs( $file );
return $abs;
@@ -567,154 +547,41 @@ sub _lwp_fetch {
};
- unless( can_load( modules => $use_list ) ) {
- $METHOD_FAIL->{'lwp'} = 1;
- return;
- }
-
- ### setup the uri object
- my $uri = URI->new( File::Spec::Unix->catfile(
- $self->path, $self->file
- ) );
-
- ### special rules apply for file:// uris ###
- $uri->scheme( $self->scheme );
- $uri->host( $self->scheme eq 'file' ? '' : $self->host );
- $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
-
- ### set up the useragent object
- my $ua = LWP::UserAgent->new();
- $ua->timeout( $TIMEOUT ) if $TIMEOUT;
- $ua->agent( $USER_AGENT );
- $ua->from( $FROM_EMAIL );
- $ua->env_proxy;
-
- my $res = $ua->mirror($uri, $to) or return;
-
- ### uptodate or fetched ok ###
- if ( $res->code == 304 or $res->code == 200 ) {
- return $to;
-
- } else {
- return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
- $res->code, HTTP::Status::status_message($res->code),
- $res->status_line));
- }
-
-}
-
-### HTTP::Tiny fetching ###
-sub _httptiny_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- my $use_list = {
- 'HTTP::Tiny' => '0.008',
-
- };
-
- unless( can_load(modules => $use_list) ) {
- $METHOD_FAIL->{'httptiny'} = 1;
- return;
- }
-
- my $uri = $self->uri;
+ if( can_load(modules => $use_list) ) {
- my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );
+ ### setup the uri object
+ my $uri = URI->new( File::Spec::Unix->catfile(
+ $self->path, $self->file
+ ) );
- my $rc = $http->mirror( $uri, $to );
+ ### special rules apply for file:// uris ###
+ $uri->scheme( $self->scheme );
+ $uri->host( $self->scheme eq 'file' ? '' : $self->host );
+ $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
- unless ( $rc->{success} ) {
+ ### set up the useragent object
+ my $ua = LWP::UserAgent->new();
+ $ua->timeout( $TIMEOUT ) if $TIMEOUT;
+ $ua->agent( $USER_AGENT );
+ $ua->from( $FROM_EMAIL );
+ $ua->env_proxy;
- return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
- $rc->{status}, $rc->{reason} ) );
+ my $res = $ua->mirror($uri, $to) or return;
- }
-
- return $to;
+ ### uptodate or fetched ok ###
+ if ( $res->code == 304 or $res->code == 200 ) {
+ return $to;
-}
-
-### HTTP::Lite fetching ###
-sub _httplite_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### modules required to download with lwp ###
- my $use_list = {
- 'HTTP::Lite' => '2.2',
-
- };
+ } else {
+ return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
+ $res->code, HTTP::Status::status_message($res->code),
+ $res->status_line));
+ }
- unless( can_load(modules => $use_list) ) {
- $METHOD_FAIL->{'httplite'} = 1;
+ } else {
+ $METHOD_FAIL->{'lwp'} = 1;
return;
}
-
- my $uri = $self->uri;
- my $retries = 0;
-
- RETRIES: while ( $retries++ < 5 ) {
-
- my $http = HTTP::Lite->new();
- # Naughty naughty but there isn't any accessor/setter
- $http->{timeout} = $TIMEOUT if $TIMEOUT;
- $http->http11_mode(1);
-
- my $fh = FileHandle->new;
-
- unless ( $fh->open($to,'>') ) {
- return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
- }
-
- $fh->autoflush(1);
-
- binmode $fh;
-
- my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh );
-
- close $fh;
-
- if ( $rc == 301 || $rc == 302 ) {
- my $loc;
- HEADERS: for ($http->headers_array) {
- /Location: (\S+)/ and $loc = $1, last HEADERS;
- }
- #$loc or last; # Think we should squeal here.
- if ($loc =~ m!^/!) {
- $uri =~ s{^(\w+?://[^/]+)/.*$}{$1};
- $uri .= $loc;
- }
- else {
- $uri = $loc;
- }
- next RETRIES;
- }
- elsif ( $rc == 200 ) {
- return $to;
- }
- else {
- return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
- $rc, $http->status_message));
- }
-
- } # Loop for 5 retries.
-
- return $self->_error("Fetch failed! Gave up after 5 tries");
-
}
### Simple IO::Socket::INET fetching ###
@@ -733,73 +600,68 @@ sub _iosock_fetch {
'IO::Select' => '0.0',
};
- unless( can_load(modules => $use_list) ) {
- $METHOD_FAIL->{'iosock'} = 1;
- return;
- }
+ if( can_load(modules => $use_list) ) {
+ my $sock = IO::Socket::INET->new(
+ PeerHost => $self->host,
+ ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
+ );
- my $sock = IO::Socket::INET->new(
- PeerHost => $self->host,
- ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
- );
-
- unless ( $sock ) {
- return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
- }
+ unless ( $sock ) {
+ return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
+ }
- my $fh = FileHandle->new;
+ my $fh = FileHandle->new;
- # Check open()
+ # Check open()
- unless ( $fh->open($to,'>') ) {
- return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
- }
+ unless ( $fh->open($to,'>') ) {
+ return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+ }
- $fh->autoflush(1);
- binmode $fh;
+ my $path = File::Spec::Unix->catfile( $self->path, $self->file );
+ my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
+ $sock->send( $req );
- my $path = File::Spec::Unix->catfile( $self->path, $self->file );
- my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
- $sock->send( $req );
+ my $select = IO::Select->new( $sock );
- my $select = IO::Select->new( $sock );
+ my $resp = '';
+ my $normal = 0;
+ while ( $select->can_read( $TIMEOUT || 60 ) ) {
+ my $ret = $sock->sysread( $resp, 4096, length($resp) );
+ if ( !defined $ret or $ret == 0 ) {
+ $select->remove( $sock );
+ $normal++;
+ }
+ }
+ close $sock;
- my $resp = '';
- my $normal = 0;
- while ( $select->can_read( $TIMEOUT || 60 ) ) {
- my $ret = $sock->sysread( $resp, 4096, length($resp) );
- if ( !defined $ret or $ret == 0 ) {
- $select->remove( $sock );
- $normal++;
- }
- }
- close $sock;
+ unless ( $normal ) {
+ return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
+ }
- unless ( $normal ) {
- return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
- }
+ # Check the "response"
+ # Strip preceeding blank lines apparently they are allowed (RFC 2616 4.1)
+ $resp =~ s/^(\x0d?\x0a)+//;
+ # Check it is an HTTP response
+ unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
+ return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
+ }
- # Check the "response"
- # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
- $resp =~ s/^(\x0d?\x0a)+//;
- # Check it is an HTTP response
- unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
- return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
- }
+ # Check for OK
+ my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
+ unless ( $code eq '200' ) {
+ return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
+ }
- # Check for OK
- my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
- unless ( $code eq '200' ) {
- return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
- }
+ print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+ close $fh;
+ return $to;
- {
- local $\;
- print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+ } else {
+ $METHOD_FAIL->{'iosock'} = 1;
+ return;
}
- close $fh;
- return $to;
}
### Net::FTP fetching
@@ -816,43 +678,44 @@ sub _netftp_fetch {
### required modules ###
my $use_list = { 'Net::FTP' => 0 };
- unless( can_load( modules => $use_list ) ) {
- $METHOD_FAIL->{'netftp'} = 1;
- return;
- }
+ if( can_load( modules => $use_list ) ) {
- ### make connection ###
- my $ftp;
- my @options = ($self->host);
- push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
- unless( $ftp = Net::FTP->new( @options ) ) {
- return $self->_error(loc("Ftp creation failed: %1",$@));
- }
+ ### make connection ###
+ my $ftp;
+ my @options = ($self->host);
+ push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
+ unless( $ftp = Net::FTP->new( @options ) ) {
+ return $self->_error(loc("Ftp creation failed: %1",$@));
+ }
- ### login ###
- unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
- return $self->_error(loc("Could not login to '%1'",$self->host));
- }
+ ### login ###
+ unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
+ return $self->_error(loc("Could not login to '%1'",$self->host));
+ }
- ### set binary mode, just in case ###
- $ftp->binary;
+ ### set binary mode, just in case ###
+ $ftp->binary;
- ### create the remote path
- ### remember remote paths are unix paths! [#11483]
- my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
+ ### create the remote path
+ ### remember remote paths are unix paths! [#11483]
+ my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
- ### fetch the file ###
- my $target;
- unless( $target = $ftp->get( $remote, $to ) ) {
- return $self->_error(loc("Could not fetch '%1' from '%2'",
- $remote, $self->host));
- }
+ ### fetch the file ###
+ my $target;
+ unless( $target = $ftp->get( $remote, $to ) ) {
+ return $self->_error(loc("Could not fetch '%1' from '%2'",
+ $remote, $self->host));
+ }
- ### log out ###
- $ftp->quit;
+ ### log out ###
+ $ftp->quit;
- return $target;
+ return $target;
+ } else {
+ $METHOD_FAIL->{'netftp'} = 1;
+ return;
+ }
}
### /bin/wget fetch ###
@@ -866,46 +729,47 @@ sub _wget_fetch {
};
check( $tmpl, \%hash ) or return;
- my $wget;
### see if we have a wget binary ###
- unless( $wget = can_run('wget') ) {
- $METHOD_FAIL->{'wget'} = 1;
- return;
- }
+ if( my $wget = can_run('wget') ) {
- ### no verboseness, thanks ###
- my $cmd = [ $wget, '--quiet' ];
+ ### no verboseness, thanks ###
+ my $cmd = [ $wget, '--quiet' ];
- ### if a timeout is set, add it ###
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+ ### if a timeout is set, add it ###
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
- ### run passive if specified ###
- push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
+ ### run passive if specified ###
+ push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
- ### set the output document, add the uri ###
- push @$cmd, '--output-document', $to, $self->uri;
+ ### set the output document, add the uri ###
+ push @$cmd, '--output-document', $to, $self->uri;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
+ return $to;
- return $to;
+ } else {
+ $METHOD_FAIL->{'wget'} = 1;
+ return;
+ }
}
### /bin/lftp fetch ###
@@ -919,66 +783,67 @@ sub _lftp_fetch {
};
check( $tmpl, \%hash ) or return;
- ### see if we have a lftp binary ###
- my $lftp;
- unless( $lftp = can_run('lftp') ) {
- $METHOD_FAIL->{'lftp'} = 1;
- return;
- }
-
- ### no verboseness, thanks ###
- my $cmd = [ $lftp, '-f' ];
+ ### see if we have a wget binary ###
+ if( my $lftp = can_run('lftp') ) {
- my $fh = File::Temp->new;
+ ### no verboseness, thanks ###
+ my $cmd = [ $lftp, '-f' ];
- my $str;
+ my $fh = File::Temp->new;
+
+ my $str;
+
+ ### if a timeout is set, add it ###
+ $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
- ### if a timeout is set, add it ###
- $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
+ ### run passive if specified ###
+ $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
- ### run passive if specified ###
- $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
+ ### set the output document, add the uri ###
+ ### quote the URI, because lftp supports certain shell
+ ### expansions, most notably & for backgrounding.
+ ### ' quote does nto work, must be "
+ $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
- ### set the output document, add the uri ###
- ### quote the URI, because lftp supports certain shell
- ### expansions, most notably & for backgrounding.
- ### ' quote does nto work, must be "
- $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
+ if( $DEBUG ) {
+ my $pp_str = join ' ', split $/, $str;
+ print "# lftp command: $pp_str\n";
+ }
- if( $DEBUG ) {
- my $pp_str = join ' ', split $/, $str;
- print "# lftp command: $pp_str\n";
- }
+ ### write straight to the file.
+ $fh->autoflush(1);
+ print $fh $str;
- ### write straight to the file.
- $fh->autoflush(1);
- print $fh $str;
+ ### the command needs to be 1 string to be executed
+ push @$cmd, $fh->filename;
- ### the command needs to be 1 string to be executed
- push @$cmd, $fh->filename;
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
+ return $to;
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ } else {
+ $METHOD_FAIL->{'lftp'} = 1;
+ return;
}
-
- return $to;
}
@@ -995,35 +860,32 @@ sub _ftp_fetch {
check( $tmpl, \%hash ) or return;
### see if we have a ftp binary ###
- my $ftp;
- unless( $ftp = can_run('ftp') ) {
- $METHOD_FAIL->{'ftp'} = 1;
- return;
- }
+ if( my $ftp = can_run('ftp') ) {
- my $fh = FileHandle->new;
+ my $fh = FileHandle->new;
- local $SIG{CHLD} = 'IGNORE';
+ local $SIG{CHLD} = 'IGNORE';
- unless ($fh->open("$ftp -n", '|-')) {
- return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
- }
+ unless ($fh->open("|$ftp -n")) {
+ return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
+ }
- my @dialog = (
- "lcd " . dirname($to),
- "open " . $self->host,
- "user anonymous $FROM_EMAIL",
- "cd /",
- "cd " . $self->path,
- "binary",
- "get " . $self->file . " " . $self->output_file,
- "quit",
- );
+ my @dialog = (
+ "lcd " . dirname($to),
+ "open " . $self->host,
+ "user anonymous $FROM_EMAIL",
+ "cd /",
+ "cd " . $self->path,
+ "binary",
+ "get " . $self->file . " " . $self->output_file,
+ "quit",
+ );
- foreach (@dialog) { $fh->print($_, "\n") }
- $fh->close or return;
+ foreach (@dialog) { $fh->print($_, "\n") }
+ $fh->close or return;
- return $to;
+ return $to;
+ }
}
### lynx is stupid - it decompresses any .gz file it finds to be text
@@ -1039,93 +901,94 @@ sub _lynx_fetch {
check( $tmpl, \%hash ) or return;
### see if we have a lynx binary ###
- my $lynx;
- unless ( $lynx = can_run('lynx') ){
- $METHOD_FAIL->{'lynx'} = 1;
- return;
- }
+ if( my $lynx = can_run('lynx') ) {
+
+ unless( IPC::Cmd->can_capture_buffer ) {
+ $METHOD_FAIL->{'lynx'} = 1;
+
+ return $self->_error(loc(
+ "Can not capture buffers. Can not use '%1' to fetch files",
+ 'lynx' ));
+ }
+
+ ### check if the HTTP resource exists ###
+ if ($self->uri =~ /^https?:\/\//i) {
+ my $cmd = [
+ $lynx,
+ '-head',
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
- unless( IPC::Cmd->can_capture_buffer ) {
- $METHOD_FAIL->{'lynx'} = 1;
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
- return $self->_error(loc(
- "Can not capture buffers. Can not use '%1' to fetch files",
- 'lynx' ));
- }
+ push @$cmd, $self->uri;
+
+ ### shell out ###
+ my $head;
+ unless(run( command => $cmd,
+ buffer => \$head,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
- ### check if the HTTP resource exists ###
- if ($self->uri =~ /^https?:\/\//i) {
+ unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+ }
+
+ ### write to the output file ourselves, since lynx ass_u_mes to much
+ my $local = FileHandle->new(">$to")
+ or return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+
+ ### dump to stdout ###
my $cmd = [
$lynx,
- '-head',
'-source',
"-auth=anonymous:$FROM_EMAIL",
];
push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
push @$cmd, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? $self->uri
+ # : QUOTE. $self->uri .QUOTE;
+
### shell out ###
- my $head;
+ my $captured;
unless(run( command => $cmd,
- buffer => \$head,
+ buffer => \$captured,
verbose => $DEBUG )
) {
- return $self->_error(loc("Command failed: %1", $head || ''));
+ return $self->_error(loc("Command failed: %1", $captured || ''));
}
- unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
- return $self->_error(loc("Command failed: %1", $head || ''));
- }
- }
+ ### print to local file ###
+ ### XXX on a 404 with a special error page, $captured will actually
+ ### hold the contents of that page, and make it *appear* like the
+ ### request was a success, when really it wasn't :(
+ ### there doesn't seem to be an option for lynx to change the exit
+ ### code based on a 4XX status or so.
+ ### the closest we can come is using --error_file and parsing that,
+ ### which is very unreliable ;(
+ $local->print( $captured );
+ $local->close or return;
- ### write to the output file ourselves, since lynx ass_u_mes to much
- my $local = FileHandle->new( $to, 'w' )
- or return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
-
- ### dump to stdout ###
- my $cmd = [
- $lynx,
- '-source',
- "-auth=anonymous:$FROM_EMAIL",
- ];
-
- push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
-
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $self->uri;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? $self->uri
- # : QUOTE. $self->uri .QUOTE;
-
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
-
- ### print to local file ###
- ### XXX on a 404 with a special error page, $captured will actually
- ### hold the contents of that page, and make it *appear* like the
- ### request was a success, when really it wasn't :(
- ### there doesn't seem to be an option for lynx to change the exit
- ### code based on a 4XX status or so.
- ### the closest we can come is using --error_file and parsing that,
- ### which is very unreliable ;(
- $local->print( $captured );
- $local->close or return;
+ return $to;
- return $to;
+ } else {
+ $METHOD_FAIL->{'lynx'} = 1;
+ return;
+ }
}
### use /bin/ncftp to fetch files
@@ -1139,43 +1002,43 @@ sub _ncftp_fetch {
};
check( $tmpl, \%hash ) or return;
- ### we can only set passive mode in interactive sessions, so bail out
+ ### we can only set passive mode in interactive sesssions, so bail out
### if $FTP_PASSIVE is set
return if $FTP_PASSIVE;
### see if we have a ncftp binary ###
- my $ncftp;
- unless( $ncftp = can_run('ncftp') ) {
- $METHOD_FAIL->{'ncftp'} = 1;
- return;
- }
+ if( my $ncftp = can_run('ncftp') ) {
- my $cmd = [
- $ncftp,
- '-V', # do not be verbose
- '-p', $FROM_EMAIL, # email as password
- $self->host, # hostname
- dirname($to), # local dir for the file
- # remote path to the file
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- $IPC::Cmd::USE_IPC_RUN
- ? File::Spec::Unix->catdir( $self->path, $self->file )
- : QUOTE. File::Spec::Unix->catdir(
- $self->path, $self->file ) .QUOTE
-
- ];
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
+ my $cmd = [
+ $ncftp,
+ '-V', # do not be verbose
+ '-p', $FROM_EMAIL, # email as password
+ $self->host, # hostname
+ dirname($to), # local dir for the file
+ # remote path to the file
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ $IPC::Cmd::USE_IPC_RUN
+ ? File::Spec::Unix->catdir( $self->path, $self->file )
+ : QUOTE. File::Spec::Unix->catdir(
+ $self->path, $self->file ) .QUOTE
+
+ ];
- return $to;
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'ncftp'} = 1;
+ return;
+ }
}
### use /bin/curl to fetch files
@@ -1188,111 +1051,57 @@ sub _curl_fetch {
to => { required => 1, store => \$to }
};
check( $tmpl, \%hash ) or return;
- my $curl;
- unless ( $curl = can_run('curl') ) {
- $METHOD_FAIL->{'curl'} = 1;
- return;
- }
-
- ### these long opts are self explanatory - I like that -jmb
- my $cmd = [ $curl, '-q' ];
-
- push(@$cmd, '-4') if $^O eq 'netbsd' && $FORCEIPV4; # only seen this on NetBSD so far
-
- push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
- push(@$cmd, '--silent') unless $DEBUG;
+ if (my $curl = can_run('curl')) {
- ### curl does the right thing with passive, regardless ###
- if ($self->scheme eq 'ftp') {
- push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
- }
+ ### these long opts are self explanatory - I like that -jmb
+ my $cmd = [ $curl, '-q' ];
- ### curl doesn't follow 302 (temporarily moved) etc automatically
- ### so we add --location to enable that.
- push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
+ push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ push(@$cmd, '--silent') unless $DEBUG;
+ ### curl does the right thing with passive, regardless ###
+ if ($self->scheme eq 'ftp') {
+ push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
+ }
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
+ ### curl doesn't follow 302 (temporarily moved) etc automatically
+ ### so we add --location to enable that.
+ push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- return $to;
-}
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
-### /usr/bin/fetch fetch! ###
-sub _fetch_fetch {
- my $self = shift;
- my %hash = @_;
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
+ return $to;
- ### see if we have a fetch binary ###
- my $fetch;
- unless( HAS_FETCH and $fetch = can_run('fetch') ) {
- $METHOD_FAIL->{'fetch'} = 1;
+ } else {
+ $METHOD_FAIL->{'curl'} = 1;
return;
}
-
- ### no verboseness, thanks ###
- my $cmd = [ $fetch, '-q' ];
-
- ### if a timeout is set, add it ###
- push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT;
-
- ### run passive if specified ###
- #push @$cmd, '-p' if $FTP_PASSIVE;
- local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE;
-
- ### set the output document, add the uri ###
- push @$cmd, '-o', $to, $self->uri;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
-
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
-
- return $to;
}
+
### use File::Copy for fetching file:// urls ###
###
### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
###
-
+
sub _file_fetch {
my $self = shift;
my %hash = @_;
@@ -1303,33 +1112,33 @@ sub _file_fetch {
};
check( $tmpl, \%hash ) or return;
-
-
+
+
### prefix a / on unix systems with a file uri, since it would
### look somewhat like this:
### file:///home/kane/file
- ### whereas windows file uris for 'c:\some\dir\file' might look like:
+ ### wheras windows file uris for 'c:\some\dir\file' might look like:
### file:///C:/some/dir/file
### file:///C|/some/dir/file
### or for a network share '\\host\share\some\dir\file':
### file:////host/share/some/dir/file
- ###
+ ###
### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
### file://vms.host.edu/disk$user/my/notes/note12345.txt
###
-
+
my $path = $self->path;
my $vol = $self->vol;
my $share = $self->share;
my $remote;
if (!$share and $self->host) {
- return $self->_error(loc(
+ return $self->_error(loc(
"Currently %1 cannot handle hosts in %2 urls",
'File::Fetch', 'file://'
- ));
+ ));
}
-
+
if( $vol ) {
$path = File::Spec->catdir( split /\//, $path );
$remote = File::Spec->catpath( $vol, $path, $self->file);
@@ -1370,87 +1179,42 @@ sub _rsync_fetch {
to => { required => 1, store => \$to }
};
check( $tmpl, \%hash ) or return;
- my $rsync;
- unless ( $rsync = can_run('rsync') ) {
- $METHOD_FAIL->{'rsync'} = 1;
- return;
- }
-
- my $cmd = [ $rsync ];
- ### XXX: rsync has no I/O timeouts at all, by default
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+ if (my $rsync = can_run('rsync')) {
- push(@$cmd, '--quiet') unless $DEBUG;
+ my $cmd = [ $rsync ];
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $self->uri, $to;
+ ### XXX: rsync has no I/O timeouts at all, by default
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ push(@$cmd, '--quiet') unless $DEBUG;
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri, $to;
- return $self->_error(loc("Command %1 failed: %2",
- "@$cmd" || '', $captured || ''));
- }
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- return $to;
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
-}
+ return $self->_error(loc("Command %1 failed: %2",
+ "@$cmd" || '', $captured || ''));
+ }
-### use git to fetch files
-sub _git_fetch {
- my $self = shift;
- my %hash = @_;
+ return $to;
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
- my $git;
- unless ( $git = can_run('git') ) {
- $METHOD_FAIL->{'git'} = 1;
+ } else {
+ $METHOD_FAIL->{'rsync'} = 1;
return;
}
-
- my $cmd = [ $git, 'clone' ];
-
- #push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
-
- push(@$cmd, '--quiet') unless $DEBUG;
-
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $self->uri, $to;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
-
- return $self->_error(loc("Command %1 failed: %2",
- "@$cmd" || '', $captured || ''));
- }
-
- return $to;
-
}
#################################
@@ -1472,10 +1236,10 @@ Pass it a true value to get the C<Carp::longmess()> output instead.
sub _error {
my $self = shift;
my $error = shift;
-
+
$self->_error_msg( $error );
$self->_error_msg_long( Carp::longmess($error) );
-
+
if( $WARN ) {
carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
}
@@ -1502,10 +1266,9 @@ Below is a mapping of what utilities will be used in what order
for what schemes, if available:
file => LWP, lftp, file
- http => LWP, HTTP::Lite, wget, curl, lftp, fetch, lynx, iosock
- ftp => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp
+ http => LWP, wget, curl, lftp, lynx, iosock
+ ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
rsync => rsync
- git => git
If you'd like to disable the use of one or more of these utilities
and/or modules, see the C<$BLACKLIST> variable further down.
@@ -1515,15 +1278,9 @@ If a utility or module isn't available, it will be marked in a cache
tried again. The C<fetch> method will only fail when all options are
exhausted, and it was not able to retrieve the file.
-The C<fetch> utility is available on FreeBSD. NetBSD and Dragonfly BSD
-may also have it from C<pkgsrc>. We only check for C<fetch> on those
-three platforms.
-
C<iosock> is a very limited L<IO::Socket::INET> based mechanism for
retrieving C<http> schemed urls. It doesn't follow redirects for instance.
-C<git> only supports C<git://> style urls.
-
A special note about fetching files from an ftp uri:
By default, all ftp connections are done in passive mode. To change
@@ -1622,8 +1379,6 @@ Here's a quick mapping for the utilities/modules, and their names for
the $BLACKLIST, $METHOD_FAIL and other internal functions.
LWP => lwp
- HTTP::Lite => httplite
- HTTP::Tiny => httptiny
Net::FTP => netftp
wget => wget
lynx => lynx
@@ -1632,7 +1387,6 @@ the $BLACKLIST, $METHOD_FAIL and other internal functions.
curl => curl
rsync => rsync
lftp => lftp
- fetch => fetch
IO::Socket => iosock
=head1 FREQUENTLY ASKED QUESTIONS
@@ -1655,21 +1409,21 @@ which we in turn capture. If that content is a 'custom' error file
Sadly, C<lynx> doesn't support any options to return a different exit
code on non-C<200 OK> status, giving us no way to tell the difference
-between a 'successful' fetch and a custom error page.
+between a 'successfull' fetch and a custom error page.
-Therefor, we recommend to only use C<lynx> as a last resort. This is
+Therefor, we recommend to only use C<lynx> as a last resort. This is
why it is at the back of our list of methods to try as well.
=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
-C<File::Fetch> is relatively smart about things. When trying to write
-a file to disk, it removes the C<query parameters> (see the
+C<File::Fetch> is relatively smart about things. When trying to write
+a file to disk, it removes the C<query parameters> (see the
C<output_file> method for details) from the file name before creating
it. In most cases this suffices.
-If you have any other characters you need to escape, please install
+If you have any other characters you need to escape, please install
the C<URI::Escape> module from CPAN, and pre-encode your URI before
-passing it to C<File::Fetch>. You can read about the details of URIs
+passing it to C<File::Fetch>. You can read about the details of URIs
and URI encoding here:
http://www.faqs.org/rfcs/rfc2396.html
@@ -1694,7 +1448,7 @@ This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
=head1 COPYRIGHT
-This library is free software; you may redistribute and/or modify it
+This library is free software; you may redistribute and/or modify it
under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm
index 57e74a8c07b..9424df63b8b 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm
@@ -1,23 +1,24 @@
package Compress::Zlib;
-require 5.006 ;
+require 5.004 ;
require Exporter;
+use AutoLoader;
use Carp ;
use IO::Handle ;
use Scalar::Util qw(dualvar);
-use IO::Compress::Base::Common 2.064 ;
-use Compress::Raw::Zlib 2.064 ;
-use IO::Compress::Gzip 2.064 ;
-use IO::Uncompress::Gunzip 2.064 ;
+use IO::Compress::Base::Common 2.024 ;
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Gzip 2.024 ;
+use IO::Uncompress::Gunzip 2.024 ;
use strict ;
use warnings ;
use bytes ;
-our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD);
-$VERSION = '2.064';
+$VERSION = '2.024';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -45,6 +46,16 @@ BEGIN
*zlib_version = \&Compress::Raw::Zlib::zlib_version;
}
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my ($error, $val) = Compress::Raw::Zlib::constant($constname);
+ Carp::croak $error if $error;
+ no strict 'refs';
+ *{$AUTOLOAD} = sub { $val };
+ goto &{$AUTOLOAD};
+}
+
use constant FLAG_APPEND => 1 ;
use constant FLAG_CRC => 2 ;
use constant FLAG_ADLER => 4 ;
@@ -87,16 +98,15 @@ sub _set_gzerr_undef
_set_gzerr(@_);
return undef;
}
-
sub _save_gzerr
{
my $gz = shift ;
my $test_eof = shift ;
my $value = $gz->errorNo() || 0 ;
- my $eof = $gz->eof() ;
if ($test_eof) {
+ #my $gz = $self->[0] ;
# gzread uses Z_STREAM_END to denote a successful end
$value = Z_STREAM_END() if $gz->eof() && $value == 0 ;
}
@@ -163,14 +173,13 @@ sub Compress::Zlib::gzFile::gzread
my $len = defined $_[1] ? $_[1] : 4096 ;
- my $gz = $self->[0] ;
if ($self->gzeof() || $len == 0) {
# Zap the output buffer to match ver 1 behaviour.
$_[0] = "" ;
- _save_gzerr($gz, 1);
return 0 ;
}
+ my $gz = $self->[0] ;
my $status = $gz->read($_[0], $len) ;
_save_gzerr($gz, 1);
return $status ;
@@ -315,14 +324,7 @@ sub compress($;$)
my $level = (@_ == 2 ? $_[1] : Z_DEFAULT_COMPRESSION() );
- $x = Compress::Raw::Zlib::_deflateInit(FLAG_APPEND,
- $level,
- Z_DEFLATED,
- MAX_WBITS,
- MAX_MEM_LEVEL,
- Z_DEFAULT_STRATEGY,
- 4096,
- '')
+ $x = new Compress::Raw::Zlib::Deflate -AppendOutput => 1, -Level => $level
or return undef ;
$err = $x->deflate($in, $output) ;
@@ -332,11 +334,12 @@ sub compress($;$)
return undef unless $err == Z_OK() ;
return $output ;
+
}
sub uncompress($)
{
- my ($output, $in) =('', '') ;
+ my ($x, $output, $err, $in) =('', '', '', '') ;
if (ref $_[0] ) {
$in = $_[0] ;
@@ -347,49 +350,47 @@ sub uncompress($)
}
$] >= 5.008 and (utf8::downgrade($$in, 1)
- or croak "Wide character in uncompress");
-
- my ($obj, $status) = Compress::Raw::Zlib::_inflateInit(0,
- MAX_WBITS, 4096, "") ;
-
- $status == Z_OK
- or return undef;
-
- $obj->inflate($in, $output) == Z_STREAM_END
- or return undef;
-
- return $output;
+ or croak "Wide character in uncompress");
+
+ $x = new Compress::Raw::Zlib::Inflate -ConsumeInput => 0 or return undef ;
+
+ $err = $x->inflate($in, $output) ;
+ return undef unless $err == Z_STREAM_END() ;
+
+ return $output ;
}
+
+
sub deflateInit(@)
{
my ($got) = ParseParameters(0,
{
- 'bufsize' => [IO::Compress::Base::Common::Parse_unsigned, 4096],
- 'level' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_COMPRESSION()],
- 'method' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFLATED()],
- 'windowbits' => [IO::Compress::Base::Common::Parse_signed, MAX_WBITS()],
- 'memlevel' => [IO::Compress::Base::Common::Parse_unsigned, MAX_MEM_LEVEL()],
- 'strategy' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFAULT_STRATEGY()],
- 'dictionary' => [IO::Compress::Base::Common::Parse_any, ""],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+ 'Level' => [1, 1, Parse_signed, Z_DEFAULT_COMPRESSION()],
+ 'Method' => [1, 1, Parse_unsigned, Z_DEFLATED()],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'MemLevel' => [1, 1, Parse_unsigned, MAX_MEM_LEVEL()],
+ 'Strategy' => [1, 1, Parse_unsigned, Z_DEFAULT_STRATEGY()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_ ) ;
croak "Compress::Zlib::deflateInit: Bufsize must be >= 1, you specified " .
- $got->getValue('bufsize')
- unless $got->getValue('bufsize') >= 1;
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
my $obj ;
my $status = 0 ;
($obj, $status) =
Compress::Raw::Zlib::_deflateInit(0,
- $got->getValue('level'),
- $got->getValue('method'),
- $got->getValue('windowbits'),
- $got->getValue('memlevel'),
- $got->getValue('strategy'),
- $got->getValue('bufsize'),
- $got->getValue('dictionary')) ;
+ $got->value('Level'),
+ $got->value('Method'),
+ $got->value('WindowBits'),
+ $got->value('MemLevel'),
+ $got->value('Strategy'),
+ $got->value('Bufsize'),
+ $got->value('Dictionary')) ;
my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldDeflate" : undef) ;
return wantarray ? ($x, $status) : $x ;
@@ -399,22 +400,22 @@ sub inflateInit(@)
{
my ($got) = ParseParameters(0,
{
- 'bufsize' => [IO::Compress::Base::Common::Parse_unsigned, 4096],
- 'windowbits' => [IO::Compress::Base::Common::Parse_signed, MAX_WBITS()],
- 'dictionary' => [IO::Compress::Base::Common::Parse_any, ""],
+ 'Bufsize' => [1, 1, Parse_unsigned, 4096],
+ 'WindowBits' => [1, 1, Parse_signed, MAX_WBITS()],
+ 'Dictionary' => [1, 1, Parse_any, ""],
}, @_) ;
croak "Compress::Zlib::inflateInit: Bufsize must be >= 1, you specified " .
- $got->getValue('bufsize')
- unless $got->getValue('bufsize') >= 1;
+ $got->value('Bufsize')
+ unless $got->value('Bufsize') >= 1;
my $status = 0 ;
my $obj ;
($obj, $status) = Compress::Raw::Zlib::_inflateInit(FLAG_CONSUME_INPUT,
- $got->getValue('windowbits'),
- $got->getValue('bufsize'),
- $got->getValue('dictionary')) ;
+ $got->value('WindowBits'),
+ $got->value('Bufsize'),
+ $got->value('Dictionary')) ;
my $x = ($status == Z_OK() ? bless $obj, "Zlib::OldInflate" : undef) ;
@@ -461,41 +462,27 @@ sub inflate
package Compress::Zlib ;
-use IO::Compress::Gzip::Constants 2.064 ;
+use IO::Compress::Gzip::Constants 2.024 ;
sub memGzip($)
{
- _set_gzerr(0);
- my $x = Compress::Raw::Zlib::_deflateInit(FLAG_APPEND|FLAG_CRC,
- Z_BEST_COMPRESSION,
- Z_DEFLATED,
- -MAX_WBITS(),
- MAX_MEM_LEVEL,
- Z_DEFAULT_STRATEGY,
- 4096,
- '')
- or return undef ;
-
- # if the deflation buffer isn't a reference, make it one
- my $string = (ref $_[0] ? $_[0] : \$_[0]) ;
+ my $out;
- $] >= 5.008 and (utf8::downgrade($$string, 1)
- or croak "Wide character in memGzip");
+ # if the deflation buffer isn't a reference, make it one
+ my $string = (ref $_[0] ? $_[0] : \$_[0]) ;
- my $out;
- my $status ;
+ $] >= 5.008 and (utf8::downgrade($$string, 1)
+ or croak "Wide character in memGzip");
- $x->deflate($string, $out) == Z_OK
- or return undef ;
-
- $x->flush($out) == Z_OK
- or return undef ;
-
- return IO::Compress::Gzip::Constants::GZIP_MINIMUM_HEADER .
- $out .
- pack("V V", $x->crc32(), $x->total_in());
-}
+ _set_gzerr(0);
+ if ( ! IO::Compress::Gzip::gzip($string, \$out, Minimal => 1) )
+ {
+ $Compress::Zlib::gzerrno = $IO::Compress::Gzip::GzipError;
+ return undef ;
+ }
+ return $out;
+}
sub _removeGzipHeader($)
{
@@ -577,11 +564,12 @@ sub memGunzip($)
or return _set_gzerr_undef($status);
my $bufsize = length $$string > 4096 ? length $$string : 4096 ;
- my $x = Compress::Raw::Zlib::_inflateInit(FLAG_CRC | FLAG_CONSUME_INPUT,
- -MAX_WBITS(), $bufsize, '')
+ my $x = new Compress::Raw::Zlib::Inflate({-WindowBits => - MAX_WBITS(),
+ -Bufsize => $bufsize})
+
or return _ret_gun_error();
- my $output = '' ;
+ my $output = "" ;
$status = $x->inflate($string, $output);
if ( $status == Z_OK() )
@@ -599,7 +587,7 @@ sub memGunzip($)
substr($$string, 0, 8) = '';
return _set_gzerr_undef(Z_DATA_ERROR())
unless $len == length($output) and
- $crc == Compress::Raw::Zlib::crc32($output);
+ $crc == crc32($output);
}
else
{
@@ -671,8 +659,8 @@ Compress::Zlib - Interface to zlib compression library
$crc = adler32($buffer [,$crc]) ;
$crc = crc32($buffer [,$crc]) ;
- $crc = crc32_combine($crc1, $crc2, $len2);
- $adler = adler32_combine($adler1, $adler2, $len2);
+ $crc = adler32_combine($crc1, $crc2, $len2)l
+ $crc = crc32_combine($adler1, $adler2, $len2)
my $version = Compress::Raw::Zlib::zlib_version();
@@ -721,7 +709,7 @@ enhancements/changes have been made to the C<gzopen> interface:
=item 1
-If you want to open either STDIN or STDOUT with C<gzopen>, you can now
+If you want to to open either STDIN or STDOUT with C<gzopen>, you can now
optionally use the special filename "C<->" as a synonym for C<\*STDIN> and
C<\*STDOUT>.
@@ -1030,7 +1018,7 @@ carry out in-memory gzip compression.
This function is used to uncompress an in-memory gzip file.
$dest = Compress::Zlib::memGunzip($buffer)
- or die "Cannot uncompress: $gzerrno\n";
+ or die "Cannot uncomprss: $gzerrno\n";
If successful, it returns the uncompressed gzip file. Otherwise it
returns C<undef> and the C<$gzerrno> variable will store the zlib error
@@ -1450,11 +1438,10 @@ If the $crc parameters is C<undef>, the crc value will be reset.
If you have built this module with zlib 1.2.3 or better, two more
CRC-related functions are available.
- $crc = crc32_combine($crc1, $crc2, $len2);
- $adler = adler32_combine($adler1, $adler2, $len2);
+ $crc = adler32_combine($crc1, $crc2, $len2)l
+ $crc = crc32_combine($adler1, $adler2, $len2)
These functions allow checksums to be merged.
-Refer to the I<zlib> documentation for more details.
=head1 Misc
@@ -1471,7 +1458,7 @@ of I<Compress::Zlib>.
L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1500,7 +1487,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 1995-2014 Paul Marquess. All rights reserved.
+Copyright (c) 1995-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/File/GlobMapper.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/File/GlobMapper.pm
index 76d4bed1178..40a606309e0 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/File/GlobMapper.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/File/GlobMapper.pm
@@ -31,7 +31,7 @@ $VERSION = '1.000';
our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
-$noPreBS = '(?<!\\\)' ; # no preceding backslash
+$noPreBS = '(?<!\\\)' ; # no preceeding backslash
$metachars = '.*?[](){}';
$matchMetaRE = '[' . quotemeta($metachars) . ']';
@@ -309,7 +309,7 @@ sub _parseOutputGlob
if $1 > $maxwild ;
}
- my $noPreBS = '(?<!\\\)' ; # no preceding backslash
+ my $noPreBS = '(?<!\\\)' ; # no preceeding backslash
#warn "noPreBS = '$noPreBS'\n";
#$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm
index c77e06b29b7..3e2e89f8e12 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm
@@ -4,12 +4,13 @@ use strict;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status);
+use IO::Compress::Base::Common 2.024 qw(:Status);
-use Compress::Raw::Bzip2 2.064 ;
+#use Compress::Bzip2 ;
+use Compress::Raw::Bzip2 2.024 ;
our ($VERSION);
-$VERSION = '2.064';
+$VERSION = '2.024';
sub mkCompObject
{
@@ -17,12 +18,11 @@ sub mkCompObject
my $WorkFactor = shift ;
my $Verbosity = shift ;
- $BlockSize100K = 1 if ! defined $BlockSize100K ;
- $WorkFactor = 0 if ! defined $WorkFactor ;
- $Verbosity = 0 if ! defined $Verbosity ;
-
my ($def, $status) = new Compress::Raw::Bzip2(1, $BlockSize100K,
$WorkFactor, $Verbosity);
+ #my ($def, $status) = bzdeflateInit();
+ #-BlockSize100K => $params->value('BlockSize100K'),
+ #-WorkFactor => $params->value('WorkFactor');
return (undef, "Could not create Deflate object: $status", $status)
if $status != BZ_OK ;
@@ -39,6 +39,7 @@ sub compr
my $def = $self->{Def};
+ #my ($out, $status) = $def->bzdeflate(defined ${$_[0]} ? ${$_[0]} : "") ;
my $status = $def->bzdeflate($_[0], $_[1]) ;
$self->{ErrorNo} = $status;
@@ -48,6 +49,8 @@ sub compr
return STATUS_ERROR;
}
+ #${ $_[1] } .= $out if defined $out;
+
return STATUS_OK;
}
@@ -57,6 +60,8 @@ sub flush
my $def = $self->{Def};
+ #my ($out, $status) = $def->bzflush($opt);
+ #my $status = $def->bzflush($_[0], $opt);
my $status = $def->bzflush($_[0]);
$self->{ErrorNo} = $status;
@@ -66,6 +71,7 @@ sub flush
return STATUS_ERROR;
}
+ #${ $_[0] } .= $out if defined $out ;
return STATUS_OK;
}
@@ -76,6 +82,7 @@ sub close
my $def = $self->{Def};
+ #my ($out, $status) = $def->bzclose();
my $status = $def->bzclose($_[0]);
$self->{ErrorNo} = $status;
@@ -85,6 +92,7 @@ sub close
return STATUS_ERROR;
}
+ #${ $_[0] } .= $out if defined $out ;
return STATUS_OK;
}
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm
index c8fdf2a2c7d..f23a9819c67 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm
@@ -4,18 +4,12 @@ use strict;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status);
-use Compress::Raw::Zlib 2.064 qw( !crc32 !adler32 ) ;
-
-require Exporter;
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS);
-
-$VERSION = '2.064';
-@ISA = qw(Exporter);
-@EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS;
-%EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS;
-@EXPORT = @EXPORT_OK;
-%DEFLATE_CONSTANTS = %EXPORT_TAGS ;
+use IO::Compress::Base::Common 2.024 qw(:Status);
+
+use Compress::Raw::Zlib 2.024 qw(Z_OK Z_FINISH MAX_WBITS) ;
+our ($VERSION);
+
+$VERSION = '2.024';
sub mkCompObject
{
@@ -74,7 +68,8 @@ sub flush
return STATUS_ERROR;
}
- return STATUS_OK;
+ return STATUS_OK;
+
}
sub close
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm
index b612de0a22b..16f14d8e7f3 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm
@@ -4,10 +4,10 @@ use strict;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status);
+use IO::Compress::Base::Common 2.024 qw(:Status);
our ($VERSION);
-$VERSION = '2.064';
+$VERSION = '2.024';
sub mkCompObject
{
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm
index 6dc791776ab..5a20f60007b 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm
@@ -1,26 +1,26 @@
package IO::Compress::Base ;
-require 5.006 ;
+require 5.004 ;
use strict ;
use warnings;
-use IO::Compress::Base::Common 2.064 ;
+use IO::Compress::Base::Common 2.024 ;
-use IO::File (); ;
-use Scalar::Util ();
+use IO::File ;
+use Scalar::Util qw(blessed readonly);
#use File::Glob;
#require Exporter ;
-use Carp() ;
-use Symbol();
-#use bytes;
+use Carp ;
+use Symbol;
+use bytes;
our (@ISA, $VERSION);
@ISA = qw(Exporter IO::File);
-$VERSION = '2.064';
+$VERSION = '2.024';
#Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16.
@@ -48,7 +48,7 @@ sub croakError
{
my $self = shift ;
$self->saveErrorString(0, $_[0]);
- Carp::croak $_[0];
+ croak $_[0];
}
sub closeError
@@ -92,11 +92,11 @@ sub writeAt
my $here = tell(*$self->{FH});
return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!)
if $here < 0 ;
- seek(*$self->{FH}, $offset, IO::Handle::SEEK_SET)
+ seek(*$self->{FH}, $offset, SEEK_SET)
or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
defined *$self->{FH}->write($data, length $data)
or return $self->saveErrorString(undef, $!, $!) ;
- seek(*$self->{FH}, $here, IO::Handle::SEEK_SET)
+ seek(*$self->{FH}, $here, SEEK_SET)
or return $self->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
}
else {
@@ -106,14 +106,6 @@ sub writeAt
return 1;
}
-sub outputPayload
-{
-
- my $self = shift ;
- return $self->output(@_);
-}
-
-
sub output
{
my $self = shift ;
@@ -123,9 +115,9 @@ sub output
return 1
if length $data == 0 && ! $last ;
- if ( *$self->{FilterContainer} ) {
+ if ( *$self->{FilterEnvelope} ) {
*_ = \$data;
- &{ *$self->{FilterContainer} }();
+ &{ *$self->{FilterEnvelope} }();
}
if (length $data) {
@@ -143,21 +135,10 @@ sub output
sub getOneShotParams
{
- return ( 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 1],
+ return ( 'MultiStream' => [1, 1, Parse_boolean, 1],
);
}
-our %PARAMS = (
- # Generic Parameters
- 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'encode' => [IO::Compress::Base::Common::Parse_any, undef],
- 'strict' => [IO::Compress::Base::Common::Parse_boolean, 1],
- 'append' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'binmodein' => [IO::Compress::Base::Common::Parse_boolean, 0],
-
- 'filtercontainer' => [IO::Compress::Base::Common::Parse_code, undef],
- );
-
sub checkParams
{
my $self = shift ;
@@ -167,14 +148,20 @@ sub checkParams
$got->parse(
{
- %PARAMS,
+ # Generic Parameters
+ 'AutoClose' => [1, 1, Parse_boolean, 0],
+ #'Encode' => [1, 1, Parse_any, undef],
+ 'Strict' => [0, 1, Parse_boolean, 1],
+ 'Append' => [1, 1, Parse_boolean, 0],
+ 'BinModeIn' => [1, 1, Parse_boolean, 0],
+ 'FilterEnvelope' => [1, 1, Parse_any, undef],
$self->getExtraParams(),
*$self->{OneShot} ? $self->getOneShotParams()
: (),
},
- @_) or $self->croakError("${class}: " . $got->getError()) ;
+ @_) or $self->croakError("${class}: $got->{Error}") ;
return $got ;
}
@@ -200,9 +187,9 @@ sub _create
or return undef ;
}
- my $lax = ! $got->getValue('strict') ;
+ my $lax = ! $got->value('Strict') ;
- my $outType = IO::Compress::Base::Common::whatIsOutput($outValue);
+ my $outType = whatIsOutput($outValue);
$obj->ckOutputParam($class, $outValue)
or return undef ;
@@ -216,10 +203,10 @@ sub _create
}
# Merge implies Append
- my $merge = $got->getValue('merge') ;
- my $appendOutput = $got->getValue('append') || $merge ;
+ my $merge = $got->value('Merge') ;
+ my $appendOutput = $got->value('Append') || $merge ;
*$obj->{Append} = $appendOutput;
- *$obj->{FilterContainer} = $got->getValue('filtercontainer') ;
+ *$obj->{FilterEnvelope} = $got->value('FilterEnvelope') ;
if ($merge)
{
@@ -234,18 +221,17 @@ sub _create
#if ($outType eq 'filename' && -e $outValue && ! -w _)
# { return $obj->saveErrorString(undef, "Output file '$outValue' is not writable" ) }
+
+
+ if ($got->parsed('Encode')) {
+ my $want_encoding = $got->value('Encode');
+ *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding);
+ }
+
$obj->ckParams($got)
or $obj->croakError("${class}: " . $obj->error());
- if ($got->getValue('encode')) {
- my $want_encoding = $got->getValue('encode');
- *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding);
- my $x = *$obj->{Encoding};
- }
- else {
- *$obj->{Encoding} = undef;
- }
-
+
$obj->saveStatus(STATUS_OK) ;
my $status ;
@@ -265,11 +251,11 @@ sub _create
if ($outType eq 'handle') {
*$obj->{FH} = $outValue ;
setBinModeOutput(*$obj->{FH}) ;
- #$outValue->flush() ;
+ $outValue->flush() ;
*$obj->{Handle} = 1 ;
if ($appendOutput)
{
- seek(*$obj->{FH}, 0, IO::Handle::SEEK_END)
+ seek(*$obj->{FH}, 0, SEEK_END)
or return $obj->saveErrorString(undef, "Cannot seek to end of output filehandle: $!", $!) ;
}
@@ -289,7 +275,6 @@ sub _create
*$obj->{Header} = $obj->mkHeader($got) ;
$obj->output( *$obj->{Header} )
or return undef;
- $obj->beforePayload();
}
else
{
@@ -298,7 +283,7 @@ sub _create
}
*$obj->{Closed} = 0 ;
- *$obj->{AutoClose} = $got->getValue('autoclose') ;
+ *$obj->{AutoClose} = $got->value('AutoClose') ;
*$obj->{Output} = $outValue;
*$obj->{ClassName} = $class;
*$obj->{Got} = $got;
@@ -311,7 +296,7 @@ sub ckOutputParam
{
my $self = shift ;
my $from = shift ;
- my $outType = IO::Compress::Base::Common::whatIsOutput($_[0]);
+ my $outType = whatIsOutput($_[0]);
$self->croakError("$from: output parameter not a filename, filehandle or scalar ref")
if ! $outType ;
@@ -320,7 +305,7 @@ sub ckOutputParam
#if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ;
$self->croakError("$from: output buffer is read-only")
- if $outType eq 'buffer' && Scalar::Util::readonly(${ $_[0] });
+ if $outType eq 'buffer' && readonly(${ $_[0] });
return 1;
}
@@ -407,7 +392,7 @@ sub _def
# finally the 1 to 1 and n to 1
return $obj->_singleTarget($x, 1, $input, $output, @_);
- Carp::croak "should not be here" ;
+ croak "should not be here" ;
}
sub _singleTarget
@@ -420,7 +405,7 @@ sub _singleTarget
if ($x->{oneInput})
{
$obj->getFileInfo($x->{Got}, $input)
- if isaScalar($input) || (isaFilename($input) and $inputIsFilename) ;
+ if isaFilename($input) and $inputIsFilename ;
my $z = $obj->_create($x->{Got}, @_)
or return undef ;
@@ -450,7 +435,7 @@ sub _singleTarget
else
{
$obj->getFileInfo($x->{Got}, $element)
- if isaScalar($element) || $isFilename;
+ if $isFilename;
$obj->_create($x->{Got}, @_)
or return undef ;
@@ -496,7 +481,7 @@ sub _wr2
$fh = new IO::File "<$input"
or return $self->saveErrorString(undef, "cannot open file '$input': $!", $!) ;
}
- binmode $fh if *$self->{Got}->valueOrDefault('binmodein') ;
+ binmode $fh if *$self->{Got}->valueOrDefault('BinModeIn') ;
my $status ;
my $buff ;
@@ -519,7 +504,7 @@ sub _wr2
return $count ;
}
- Carp::croak "Should not be here";
+ croak "Should not be here";
return undef;
}
@@ -529,16 +514,16 @@ sub addInterStream
my $input = shift ;
my $inputIsFilename = shift ;
- if (*$self->{Got}->getValue('multistream'))
+ if (*$self->{Got}->value('MultiStream'))
{
$self->getFileInfo(*$self->{Got}, $input)
#if isaFilename($input) and $inputIsFilename ;
- if isaScalar($input) || isaFilename($input) ;
+ if isaFilename($input) ;
# TODO -- newStream needs to allow gzip/zip header to be modified
return $self->newStream();
}
- elsif (*$self->{Got}->getValue('autoflush'))
+ elsif (*$self->{Got}->value('AutoFlush'))
{
#return $self->flush(Z_FULL_FLUSH);
}
@@ -595,6 +580,10 @@ sub syswrite
$buffer = \$_[0] ;
}
+ $] >= 5.008 and ( utf8::downgrade($$buffer, 1)
+ or croak "Wide character in " . *$self->{ClassName} . "::write:");
+
+
if (@_ > 1) {
my $slen = defined $$buffer ? length($$buffer) : 0;
my $len = $slen;
@@ -616,23 +605,11 @@ sub syswrite
$buffer = \substr($$buffer, $offset, $len) ;
}
- return 0 if (! defined $$buffer || length $$buffer == 0) && ! *$self->{FlushPending};
-
-# *$self->{Pending} .= $$buffer ;
-#
-# return length $$buffer
-# if (length *$self->{Pending} < 1024 * 16 && ! *$self->{FlushPending}) ;
-#
-# $$buffer = *$self->{Pending} ;
-# *$self->{Pending} = '';
-
- if (*$self->{Encoding}) {
+ return 0 if ! defined $$buffer || length $$buffer == 0 ;
+
+ if (*$self->{Encoding}) {
$$buffer = *$self->{Encoding}->encode($$buffer);
}
- else {
- $] >= 5.008 and ( utf8::downgrade($$buffer, 1)
- or Carp::croak "Wide character in " . *$self->{ClassName} . "::write:");
- }
$self->filterUncompressed($buffer);
@@ -648,7 +625,7 @@ sub syswrite
*$self->{CompSize}->add(length $outBuffer) ;
- $self->outputPayload($outBuffer)
+ $self->output($outBuffer)
or return undef;
return $buffer_length;
@@ -684,7 +661,9 @@ sub printf
defined $self->syswrite(sprintf($fmt, @_));
}
-sub _flushCompressed
+
+
+sub flush
{
my $self = shift ;
@@ -700,17 +679,8 @@ sub _flushCompressed
*$self->{CompSize}->add(length $outBuffer) ;
- $self->outputPayload($outBuffer)
+ $self->output($outBuffer)
or return 0;
- return 1;
-}
-
-sub flush
-{
- my $self = shift ;
-
- $self->_flushCompressed(@_)
- or return 0;
if ( defined *$self->{FH} ) {
defined *$self->{FH}->flush()
@@ -720,31 +690,19 @@ sub flush
return 1;
}
-sub beforePayload
-{
-}
-
-sub _newStream
+sub newStream
{
my $self = shift ;
- my $got = shift;
-
- my $class = ref $self;
-
+
$self->_writeTrailer()
or return 0 ;
+ my $got = $self->checkParams('newStream', *$self->{Got}, @_)
+ or return 0 ;
+
$self->ckParams($got)
or $self->croakError("newStream: $self->{Error}");
- if ($got->getValue('encode')) {
- my $want_encoding = $got->getValue('encode');
- *$self->{Encoding} = IO::Compress::Base::Common::getEncoding($self, $class, $want_encoding);
- }
- else {
- *$self->{Encoding} = undef;
- }
-
*$self->{Compress} = $self->mkComp($got)
or return 0;
@@ -755,35 +713,9 @@ sub _newStream
*$self->{UnCompSize}->reset();
*$self->{CompSize}->reset();
- $self->beforePayload();
-
return 1 ;
}
-sub newStream
-{
- my $self = shift ;
-
- my $got = $self->checkParams('newStream', *$self->{Got}, @_)
- or return 0 ;
-
- $self->_newStream($got);
-
-# *$self->{Compress} = $self->mkComp($got)
-# or return 0;
-#
-# *$self->{Header} = $self->mkHeader($got) ;
-# $self->output(*$self->{Header} )
-# or return 0;
-#
-# *$self->{UnCompSize}->reset();
-# *$self->{CompSize}->reset();
-#
-# $self->beforePayload();
-#
-# return 1 ;
-}
-
sub reset
{
my $self = shift ;
@@ -819,13 +751,13 @@ sub _writeFinalTrailer
sub close
{
my $self = shift ;
+
return 1 if *$self->{Closed} || ! *$self->{Compress} ;
*$self->{Closed} = 1 ;
untie *$self
if $] >= 5.008 ;
- *$self->{FlushPending} = 1 ;
$self->_writeTrailer()
or return 0 ;
@@ -837,6 +769,7 @@ sub close
if (defined *$self->{FH}) {
+ #if (! *$self->{Handle} || *$self->{AutoClose}) {
if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
$! = 0 ;
*$self->{FH}->close()
@@ -980,7 +913,7 @@ sub input_line_number
sub _notAvailable
{
my $name = shift ;
- return sub { Carp::croak "$name Not Available: File opened only for output" ; } ;
+ return sub { croak "$name Not Available: File opened only for output" ; } ;
}
*read = _notAvailable('read');
@@ -1019,13 +952,13 @@ IO::Compress::Base - Base Class for IO::Compress modules
=head1 DESCRIPTION
This module is not intended for direct use in application code. Its sole
-purpose is to be sub-classed by IO::Compress modules.
+purpose if to to be sub-classed by IO::Compress modules.
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1041,7 +974,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm
index aa61c792c86..4f8b4dadc36 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm
@@ -11,18 +11,14 @@ use File::GlobMapper;
require Exporter;
our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
@ISA = qw(Exporter);
-$VERSION = '2.064';
+$VERSION = '2.024';
-@EXPORT = qw( isaFilehandle isaFilename isaScalar
- whatIsInput whatIsOutput
+@EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
isaFileGlobString cleanFileGlobString oneTarget
setBinModeInput setBinModeOutput
ckInOutParams
createSelfTiedObject
-
- isGeMax32
-
- MAX32
+ getEncoding
WANT_CODE
WANT_EXT
@@ -46,16 +42,7 @@ use constant STATUS_OK => 0;
use constant STATUS_ENDSTREAM => 1;
use constant STATUS_EOF => 2;
use constant STATUS_ERROR => -1;
-use constant MAX16 => 0xFFFF ;
-use constant MAX32 => 0xFFFFFFFF ;
-use constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value
-
-sub isGeMax32
-{
- return $_[0] >= MAX32cmp ;
-}
-
sub hasEncode()
{
if (! defined $HAS_ENCODE) {
@@ -105,7 +92,7 @@ sub setBinModeOutput($)
{
my $handle = shift ;
- binmode $handle
+ binmode $handle
if $needBinmode;
}
@@ -119,11 +106,6 @@ sub isaFilehandle($)
)
}
-sub isaScalar
-{
- return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ;
-}
-
sub isaFilename($)
{
return (defined $_[0] and
@@ -376,10 +358,10 @@ sub IO::Compress::Base::Validator::validateInputFilenames
return $self->saveErrorString("input file '$filename' is a directory");
}
-# if (! -r _ )
-# {
-# return $self->saveErrorString("cannot open file '$filename': $!");
-# }
+ if (! -r _ )
+ {
+ return $self->saveErrorString("cannot open file '$filename': $!");
+ }
}
return 1 ;
@@ -469,9 +451,8 @@ sub createSelfTiedObject
$EXPORT_TAGS{Parse} = [qw( ParseParameters
Parse_any Parse_unsigned Parse_signed
- Parse_boolean Parse_string
- Parse_code
- Parse_writable_scalar
+ Parse_boolean Parse_custom Parse_string
+ Parse_multiple Parse_writable_scalar
)
];
@@ -482,10 +463,10 @@ use constant Parse_unsigned => 0x02;
use constant Parse_signed => 0x04;
use constant Parse_boolean => 0x08;
use constant Parse_string => 0x10;
-use constant Parse_code => 0x20;
+use constant Parse_custom => 0x12;
#use constant Parse_store_ref => 0x100 ;
-#use constant Parse_multiple => 0x100 ;
+use constant Parse_multiple => 0x100 ;
use constant Parse_writable => 0x200 ;
use constant Parse_writable_scalar => 0x400 | Parse_writable ;
@@ -493,11 +474,10 @@ use constant OFF_PARSED => 0 ;
use constant OFF_TYPE => 1 ;
use constant OFF_DEFAULT => 2 ;
use constant OFF_FIXED => 3 ;
-#use constant OFF_FIRST_ONLY => 4 ;
-#use constant OFF_STICKY => 5 ;
+use constant OFF_FIRST_ONLY => 4 ;
+use constant OFF_STICKY => 5 ;
+
-use constant IxError => 0;
-use constant IxGot => 1 ;
sub ParseParameters
{
@@ -511,60 +491,26 @@ sub ParseParameters
my $p = new IO::Compress::Base::Parameters() ;
$p->parse(@_)
- or croak "$sub: $p->[IxError]" ;
+ or croak "$sub: $p->{Error}" ;
return $p;
}
+#package IO::Compress::Base::Parameters;
use strict;
-
use warnings;
use Carp;
-
-sub Init
-{
- my $default = shift ;
- my %got ;
-
- my $obj = IO::Compress::Base::Parameters::new();
- while (my ($key, $v) = each %$default)
- {
- croak "need 2 params [@$v]"
- if @$v != 2 ;
-
- my ($type, $value) = @$v ;
-# my ($first_only, $sticky, $type, $value) = @$v ;
- my $sticky = 0;
- my $x ;
- $obj->_checkType($key, \$value, $type, 0, \$x)
- or return undef ;
-
- $key = lc $key;
-
-# if (! $sticky) {
-# $x = []
-# if $type & Parse_multiple;
-
-# $got{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
- $got{$key} = [0, $type, $value, $x] ;
-# }
-#
-# $got{$key}[OFF_PARSED] = 0 ;
- }
-
- return bless \%got, "IO::Compress::Base::Parameters::Defaults" ;
-}
-
sub IO::Compress::Base::Parameters::new
{
- #my $class = shift ;
+ my $class = shift ;
- my $obj;
- $obj->[IxError] = '';
- $obj->[IxGot] = {} ;
+ my $obj = { Error => '',
+ Got => {},
+ } ;
+ #return bless $obj, ref($class) || $class || __PACKAGE__ ;
return bless $obj, 'IO::Compress::Base::Parameters' ;
}
@@ -574,24 +520,25 @@ sub IO::Compress::Base::Parameters::setError
my $error = shift ;
my $retval = @_ ? shift : undef ;
-
- $self->[IxError] = $error ;
+ $self->{Error} = $error ;
return $retval;
}
-sub IO::Compress::Base::Parameters::getError
-{
- my $self = shift ;
- return $self->[IxError] ;
-}
+#sub getError
+#{
+# my $self = shift ;
+# return $self->{Error} ;
+#}
sub IO::Compress::Base::Parameters::parse
{
my $self = shift ;
+
my $default = shift ;
- my $got = $self->[IxGot] ;
+ my $got = $self->{Got} ;
my $firstTime = keys %{ $got } == 0 ;
+ my $other;
my (@Bad) ;
my @entered = () ;
@@ -613,35 +560,63 @@ sub IO::Compress::Base::Parameters::parse
}
}
else {
-
my $count = @_;
return $self->setError("Expected even number of parameters, got $count")
if $count % 2 != 0 ;
for my $i (0.. $count / 2 - 1) {
- push @entered, $_[2 * $i] ;
- push @entered, \$_[2 * $i + 1] ;
+ if ($_[2 * $i] eq '__xxx__') {
+ $other = $_[2 * $i + 1] ;
+ }
+ else {
+ push @entered, $_[2 * $i] ;
+ push @entered, \$_[2 * $i + 1] ;
+ }
}
}
- foreach my $key (keys %$default)
- {
-
- my ($type, $value) = @{ $default->{$key} } ;
-
- if ($firstTime) {
- $got->{$key} = [0, $type, $value, $value] ;
- }
- else
- {
- $got->{$key}[OFF_PARSED] = 0 ;
- }
+
+ while (my ($key, $v) = each %$default)
+ {
+ croak "need 4 params [@$v]"
+ if @$v != 4 ;
+
+ my ($first_only, $sticky, $type, $value) = @$v ;
+ my $x ;
+ $self->_checkType($key, \$value, $type, 0, \$x)
+ or return undef ;
+
+ $key = lc $key;
+
+ if ($firstTime || ! $sticky) {
+ $x = []
+ if $type & Parse_multiple;
+
+ $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
}
+ $got->{$key}[OFF_PARSED] = 0 ;
+ }
my %parsed = ();
-
+ if ($other)
+ {
+ for my $key (keys %$default)
+ {
+ my $canonkey = lc $key;
+ if ($other->parsed($canonkey))
+ {
+ my $value = $other->value($canonkey);
+#print "SET '$canonkey' to $value [$$value]\n";
+ ++ $parsed{$canonkey};
+ $got->{$canonkey}[OFF_PARSED] = 1;
+ $got->{$canonkey}[OFF_DEFAULT] = $value;
+ $got->{$canonkey}[OFF_FIXED] = $value;
+ }
+ }
+ }
+
for my $i (0.. @entered / 2 - 1) {
my $key = $entered[2* $i] ;
my $value = $entered[2* $i+1] ;
@@ -652,22 +627,28 @@ sub IO::Compress::Base::Parameters::parse
$key =~ s/^-// ;
my $canonkey = lc $key;
- if ($got->{$canonkey})
+ if ($got->{$canonkey} && ($firstTime ||
+ ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
{
my $type = $got->{$canonkey}[OFF_TYPE] ;
my $parsed = $parsed{$canonkey};
++ $parsed{$canonkey};
return $self->setError("Muliple instances of '$key' found")
- if $parsed ;
+ if $parsed && $type & Parse_multiple == 0 ;
my $s ;
$self->_checkType($key, $value, $type, 1, \$s)
or return undef ;
$value = $$value ;
- $got->{$canonkey} = [1, $type, $value, $s] ;
-
+ if ($type & Parse_multiple) {
+ $got->{$canonkey}[OFF_PARSED] = 1;
+ push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
+ }
+ else {
+ $got->{$canonkey} = [1, $type, $value, $s] ;
+ }
}
else
{ push (@Bad, $key) }
@@ -697,19 +678,19 @@ sub IO::Compress::Base::Parameters::_checkType
if ($type & Parse_writable_scalar)
{
return $self->setError("Parameter '$key' not writable")
- if readonly $$value ;
+ if $validate && readonly $$value ;
if (ref $$value)
{
return $self->setError("Parameter '$key' not a scalar reference")
- if ref $$value ne 'SCALAR' ;
+ if $validate && ref $$value ne 'SCALAR' ;
$$output = $$value ;
}
else
{
return $self->setError("Parameter '$key' not a scalar")
- if ref $value ne 'SCALAR' ;
+ if $validate && ref $value ne 'SCALAR' ;
$$output = $value ;
}
@@ -717,6 +698,14 @@ sub IO::Compress::Base::Parameters::_checkType
return 1;
}
+# if ($type & Parse_store_ref)
+# {
+# #$value = $$value
+# # if ref ${ $value } ;
+#
+# $$output = $value ;
+# return 1;
+# }
$value = $$value ;
@@ -727,21 +716,20 @@ sub IO::Compress::Base::Parameters::_checkType
}
elsif ($type & Parse_unsigned)
{
-
return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
- if ! defined $value ;
+ if $validate && ! defined $value ;
return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
- if $value !~ /^\d+$/;
-
+ if $validate && $value !~ /^\d+$/;
+
$$output = defined $value ? $value : 0 ;
return 1;
}
elsif ($type & Parse_signed)
{
return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
- if ! defined $value ;
+ if $validate && ! defined $value ;
return $self->setError("Parameter '$key' must be a signed int, got '$value'")
- if $value !~ /^-?\d+$/;
+ if $validate && $value !~ /^-?\d+$/;
$$output = defined $value ? $value : 0 ;
return 1 ;
@@ -749,50 +737,43 @@ sub IO::Compress::Base::Parameters::_checkType
elsif ($type & Parse_boolean)
{
return $self->setError("Parameter '$key' must be an int, got '$value'")
- if defined $value && $value !~ /^\d*$/;
-
- $$output = defined $value && $value != 0 ? 1 : 0 ;
+ if $validate && defined $value && $value !~ /^\d*$/;
+ $$output = defined $value ? $value != 0 : 0 ;
return 1;
}
-
elsif ($type & Parse_string)
{
$$output = defined $value ? $value : "" ;
return 1;
}
- elsif ($type & Parse_code)
- {
- return $self->setError("Parameter '$key' must be a code reference, got '$value'")
- if (! defined $value || ref $value ne 'CODE') ;
- $$output = defined $value ? $value : "" ;
- return 1;
- }
-
$$output = $value ;
return 1;
}
-sub IO::Compress::Base::Parameters::parsed
-{
- return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
-}
-sub IO::Compress::Base::Parameters::getValue
-{
- return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
-}
-sub IO::Compress::Base::Parameters::setValue
+sub IO::Compress::Base::Parameters::parsed
{
- $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1;
- $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ;
- $_[0]->[IxGot]{$_[1]}[OFF_FIXED] = $_[2] ;
+ my $self = shift ;
+ my $name = shift ;
+
+ return $self->{Got}{lc $name}[OFF_PARSED] ;
}
-sub IO::Compress::Base::Parameters::valueRef
+sub IO::Compress::Base::Parameters::value
{
- return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
+ my $self = shift ;
+ my $name = shift ;
+
+ if (@_)
+ {
+ $self->{Got}{lc $name}[OFF_PARSED] = 1;
+ $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
+ $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
+ }
+
+ return $self->{Got}{lc $name}[OFF_FIXED] ;
}
sub IO::Compress::Base::Parameters::valueOrDefault
@@ -801,31 +782,33 @@ sub IO::Compress::Base::Parameters::valueOrDefault
my $name = shift ;
my $default = shift ;
- my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ;
-
+ my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
+
return $value if defined $value ;
return $default ;
}
sub IO::Compress::Base::Parameters::wantValue
{
- return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
+ my $self = shift ;
+ my $name = shift ;
+
+ return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
+
}
sub IO::Compress::Base::Parameters::clone
{
my $self = shift ;
- my $obj = [] ;
+ my $obj = { };
my %got ;
- my $hash = $self->[IxGot] ;
- for my $k (keys %{ $hash })
- {
- $got{$k} = [ @{ $hash->{$k} } ];
+ while (my ($k, $v) = each %{ $self->{Got} }) {
+ $got{$k} = [ @$v ];
}
- $obj->[IxError] = $self->[IxError];
- $obj->[IxGot] = \%got ;
+ $obj->{Error} = $self->{Error};
+ $obj->{Got} = \%got ;
return bless $obj, 'IO::Compress::Base::Parameters' ;
}
@@ -839,19 +822,27 @@ use constant HIGH => 1;
sub new
{
- return bless [ 0, 0 ], $_[0]
- if @_ == 1 ;
-
- return bless [ $_[1], 0 ], $_[0]
- if @_ == 2 ;
-
- return bless [ $_[2], $_[1] ], $_[0]
- if @_ == 3 ;
+ my $class = shift ;
+
+ my $high = 0 ;
+ my $low = 0 ;
+
+ if (@_ == 2) {
+ $high = shift ;
+ $low = shift ;
+ }
+ elsif (@_ == 1) {
+ $low = shift ;
+ }
+
+ bless [$low, $high], $class;
}
sub newUnpack_V64
{
- my ($low, $hi) = unpack "V V", $_[0] ;
+ my $string = shift;
+
+ my ($low, $hi) = unpack "V V", $string ;
bless [ $low, $hi ], "U64";
}
@@ -865,107 +856,62 @@ sub newUnpack_V32
sub reset
{
- $_[0]->[HIGH] = $_[0]->[LOW] = 0;
+ my $self = shift;
+ $self->[HIGH] = $self->[LOW] = 0;
}
sub clone
{
- bless [ @{$_[0]} ], ref $_[0] ;
+ my $self = shift;
+ bless [ @$self ], ref $self ;
}
sub getHigh
{
- return $_[0]->[HIGH];
+ my $self = shift;
+ return $self->[HIGH];
}
sub getLow
{
- return $_[0]->[LOW];
+ my $self = shift;
+ return $self->[LOW];
}
sub get32bit
{
- return $_[0]->[LOW];
+ my $self = shift;
+ return $self->[LOW];
}
sub get64bit
{
+ my $self = shift;
# Not using << here because the result will still be
# a 32-bit value on systems where int size is 32-bits
- return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW];
+ return $self->[HIGH] * HI_1 + $self->[LOW];
}
sub add
{
-# my $self = shift;
- my $value = $_[1];
+ my $self = shift;
+ my $value = shift;
if (ref $value eq 'U64') {
- $_[0]->[HIGH] += $value->[HIGH] ;
+ $self->[HIGH] += $value->[HIGH] ;
$value = $value->[LOW];
}
- elsif ($value > MAX32) {
- $_[0]->[HIGH] += int($value / HI_1) ;
- $value = $value % HI_1;
- }
- my $available = MAX32 - $_[0]->[LOW] ;
-
- if ($value > $available) {
- ++ $_[0]->[HIGH] ;
- $_[0]->[LOW] = $value - $available - 1;
- }
- else {
- $_[0]->[LOW] += $value ;
- }
-}
-
-sub add32
-{
-# my $self = shift;
- my $value = $_[1];
+ my $available = MAX32 - $self->[LOW] ;
- if ($value > MAX32) {
- $_[0]->[HIGH] += int($value / HI_1) ;
- $value = $value % HI_1;
- }
-
- my $available = MAX32 - $_[0]->[LOW] ;
-
if ($value > $available) {
- ++ $_[0]->[HIGH] ;
- $_[0]->[LOW] = $value - $available - 1;
+ ++ $self->[HIGH] ;
+ $self->[LOW] = $value - $available - 1;
}
else {
- $_[0]->[LOW] += $value ;
- }
-}
-
-sub subtract
-{
- my $self = shift;
- my $value = shift;
-
- if (ref $value eq 'U64') {
-
- if ($value->[HIGH]) {
- die "bad"
- if $self->[HIGH] == 0 ||
- $value->[HIGH] > $self->[HIGH] ;
-
- $self->[HIGH] -= $value->[HIGH] ;
- }
-
- $value = $value->[LOW] ;
+ $self->[LOW] += $value ;
}
- if ($value > $self->[LOW]) {
- -- $self->[HIGH] ;
- $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ;
- }
- else {
- $self->[LOW] -= $value;
- }
}
sub equal
@@ -977,66 +923,31 @@ sub equal
$self->[HIGH] == $other->[HIGH] ;
}
-sub gt
+sub is64bit
{
my $self = shift;
- my $other = shift;
-
- return $self->cmp($other) > 0 ;
+ return $self->[HIGH] > 0 ;
}
-sub cmp
+sub getPacked_V64
{
my $self = shift;
- my $other = shift ;
-
- if ($self->[LOW] == $other->[LOW]) {
- return $self->[HIGH] - $other->[HIGH] ;
- }
- else {
- return $self->[LOW] - $other->[LOW] ;
- }
-}
-
-
-sub is64bit
-{
- return $_[0]->[HIGH] > 0 ;
-}
-
-sub isAlmost64bit
-{
- return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ;
-}
-sub getPacked_V64
-{
- return pack "V V", @{ $_[0] } ;
+ return pack "V V", @$self ;
}
sub getPacked_V32
{
- return pack "V", $_[0]->[LOW] ;
-}
-
-sub pack_V64
-{
- return pack "V V", $_[0], 0;
-}
-
+ my $self = shift;
-sub full32
-{
- return $_[0] == MAX32 ;
+ return pack "V", $self->[LOW] ;
}
-sub Value_VV64
+sub pack_V64
{
- my $buffer = shift;
+ my $low = shift;
- my ($lo, $hi) = unpack ("V V" , $buffer);
- no warnings 'uninitialized';
- return $hi * HI_1 + $lo;
+ return pack "V V", $low, 0;
}
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm
index fc62b4f4f95..2a85ef55b19 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm
@@ -5,16 +5,16 @@ use warnings;
use bytes;
require Exporter ;
-use IO::Compress::Base 2.064 ;
+use IO::Compress::Base 2.024 ;
-use IO::Compress::Base::Common 2.064 qw();
-use IO::Compress::Adapter::Bzip2 2.064 ;
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
+use IO::Compress::Adapter::Bzip2 2.024 ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error);
-$VERSION = '2.064';
+$VERSION = '2.024';
$Bzip2Error = '';
@ISA = qw(Exporter IO::Compress::Base);
@@ -29,13 +29,13 @@ sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bzip2Error);
+ my $obj = createSelfTiedObject($class, \$Bzip2Error);
return $obj->_create(undef, @_);
}
sub bzip2
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bzip2Error);
+ my $obj = createSelfTiedObject(undef, \$Bzip2Error);
$obj->_def(@_);
}
@@ -51,12 +51,12 @@ sub getExtraParams
{
my $self = shift ;
- use IO::Compress::Base::Common 2.064 qw(:Parse);
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
- return (
- 'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1],
- 'workfactor' => [IO::Compress::Base::Common::Parse_unsigned, 0],
- 'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0],
+ return (
+ 'BlockSize100K' => [0, 1, Parse_unsigned, 1],
+ 'WorkFactor' => [0, 1, Parse_unsigned, 0],
+ 'Verbosity' => [0, 1, Parse_boolean, 0],
);
}
@@ -68,16 +68,16 @@ sub ckParams
my $got = shift;
# check that BlockSize100K is a number between 1 & 9
- if ($got->parsed('blocksize100k')) {
- my $value = $got->getValue('blocksize100k');
+ if ($got->parsed('BlockSize100K')) {
+ my $value = $got->value('BlockSize100K');
return $self->saveErrorString(undef, "Parameter 'BlockSize100K' not between 1 and 9, got $value")
unless defined $value && $value >= 1 && $value <= 9;
}
# check that WorkFactor between 0 & 250
- if ($got->parsed('workfactor')) {
- my $value = $got->getValue('workfactor');
+ if ($got->parsed('WorkFactor')) {
+ my $value = $got->value('WorkFactor');
return $self->saveErrorString(undef, "Parameter 'WorkFactor' not between 0 and 250, got $value")
unless $value >= 0 && $value <= 250;
}
@@ -91,9 +91,9 @@ sub mkComp
my $self = shift ;
my $got = shift ;
- my $BlockSize100K = $got->getValue('blocksize100k');
- my $WorkFactor = $got->getValue('workfactor');
- my $Verbosity = $got->getValue('verbosity');
+ my $BlockSize100K = $got->value('BlockSize100K');
+ my $WorkFactor = $got->value('WorkFactor');
+ my $Verbosity = $got->value('Verbosity');
my ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject(
$BlockSize100K, $WorkFactor,
@@ -204,20 +204,19 @@ section.
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
- bzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ bzip2 $input => $output [,OPTS]
or die "bzip2 failed: $Bzip2Error\n";
The functional interface needs Perl5.005 or better.
-=head2 bzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 bzip2 $input => $output [, OPTS]
-C<bzip2> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<bzip2> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the uncompressed data.
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
It can take one of the following forms:
@@ -225,25 +224,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -252,72 +251,65 @@ contains valid filenames before any data is compressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<bzip2> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<bzip2> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the compressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-compressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-compressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-compressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the compressed data will be pushed onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<bzip2> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<bzip2> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple files/buffers and
-C<$output_filename_or_reference> is a single
+When C<$input> maps to multiple files/buffers and C<$output> is a single
file/buffer the input files/buffers will be stored
-in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
+in C<$output> as a concatenated series of compressed data streams.
=head2 Optional Parameters
@@ -346,48 +338,7 @@ Defaults to 0.
=item C<< Append => 0|1 >>
-The behaviour of this option is dependent on the type of output data
-stream.
-
-=over 5
-
-=item * A Buffer
-
-If C<Append> is enabled, all compressed data will be append to the end of
-the output buffer. Otherwise the output buffer will be cleared before any
-compressed data is written to it.
-
-=item * A Filename
-
-If C<Append> is enabled, the file will be opened in append mode. Otherwise
-the contents of the file, if any, will be truncated before any compressed
-data is written to it.
-
-=item * A Filehandle
-
-If C<Append> is enabled, the filehandle will be positioned to the end of
-the file via a call to C<seek> before any compressed data is
-written to it. Otherwise the file pointer will not be moved.
-
-=back
-
-When C<Append> is specified, and set to true, it will I<append> all compressed
-data to the output data stream.
-
-So when the output is a filehandle it will carry out a seek to the eof
-before writing any compressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all compressed data will be
-appended to the existing buffer.
-
-Conversely when C<Append> is not specified, or it is present and is set to
-false, it will operate as follows.
-
-When the output is a filename, it will truncate the contents of the file
-before writing any compressed data. If the output is a filehandle
-its position will not be changed. If the output is a buffer, it will be
-wiped before any compressed data is output.
-
-Defaults to 0.
+TODO
=back
@@ -516,7 +467,7 @@ The behaviour of this option is dependent on the type of C<$output>.
=item * A Buffer
If C<$output> is a buffer and C<Append> is enabled, all compressed data
-will be append to the end of C<$output>. Otherwise C<$output> will be
+will be append to the end if C<$output>. Otherwise C<$output> will be
cleared before any data is written to it.
=item * A Filename
@@ -706,7 +657,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -742,7 +693,7 @@ Usage is
Closes the current compressed data stream and starts a new one.
-OPTS consists of any of the options that are available when creating
+OPTS consists of any of the the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
@@ -768,17 +719,19 @@ Same as doing this
=head2 Apache::GZip Revisited
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Apache::GZip Revisited">
+
+
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+See L<IO::Compress::Bzip2::FAQ|IO::Compress::Bzip2::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
-L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -798,7 +751,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2008 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm
index d8848d7f696..0f46e59d3a4 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm
@@ -1,29 +1,26 @@
package IO::Compress::Deflate ;
-require 5.006 ;
-
use strict ;
use warnings;
use bytes;
require Exporter ;
-use IO::Compress::RawDeflate 2.064 ();
-use IO::Compress::Adapter::Deflate 2.064 ;
+use IO::Compress::RawDeflate 2.024 ;
-use IO::Compress::Zlib::Constants 2.064 ;
-use IO::Compress::Base::Common 2.064 qw();
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Zlib::Constants 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError);
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $DeflateError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$DeflateError = '';
@ISA = qw(Exporter IO::Compress::RawDeflate);
@EXPORT_OK = qw( $DeflateError deflate ) ;
%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
-
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
@@ -32,13 +29,13 @@ sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$DeflateError);
+ my $obj = createSelfTiedObject($class, \$DeflateError);
return $obj->_create(undef, @_);
}
sub deflate
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$DeflateError);
+ my $obj = createSelfTiedObject(undef, \$DeflateError);
return $obj->_def(@_);
}
@@ -85,8 +82,8 @@ sub mkHeader
my $self = shift ;
my $param = shift ;
- my $level = $param->getValue('level');
- my $strategy = $param->getValue('strategy');
+ my $level = $param->value('Level');
+ my $strategy = $param->value('Strategy');
my $lflag ;
$level = 6
@@ -119,7 +116,7 @@ sub ckParams
my $self = shift ;
my $got = shift;
- $got->setValue('adler32' => 1);
+ $got->value('ADLER32' => 1);
return 1 ;
}
@@ -233,20 +230,19 @@ section.
use IO::Compress::Deflate qw(deflate $DeflateError) ;
- deflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ deflate $input => $output [,OPTS]
or die "deflate failed: $DeflateError\n";
The functional interface needs Perl5.005 or better.
-=head2 deflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 deflate $input => $output [, OPTS]
-C<deflate> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<deflate> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the uncompressed data.
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
It can take one of the following forms:
@@ -254,25 +250,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -281,72 +277,65 @@ contains valid filenames before any data is compressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<deflate> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<deflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the compressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-compressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-compressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-compressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the compressed data will be pushed onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<deflate> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
-
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<deflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple files/buffers and
-C<$output_filename_or_reference> is a single
+When C<$input> maps to multiple files/buffers and C<$output> is a single
file/buffer the input files/buffers will be stored
-in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
+in C<$output> as a concatenated series of compressed data streams.
=head2 Optional Parameters
@@ -405,8 +394,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any compressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all compressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -785,7 +774,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -821,7 +810,7 @@ Usage is
Closes the current compressed data stream and starts a new one.
-OPTS consists of any of the options that are available when creating
+OPTS consists of any of the the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
@@ -895,6 +884,8 @@ These symbolic constants are used by the C<Strategy> option in the constructor.
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
@@ -903,7 +894,7 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -932,7 +923,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm
index febeea6ca91..1978b91b283 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm
@@ -1,19 +1,19 @@
+
package IO::Compress::Gzip ;
-require 5.006 ;
+require 5.004 ;
use strict ;
use warnings;
use bytes;
-require Exporter ;
-use IO::Compress::RawDeflate 2.064 () ;
-use IO::Compress::Adapter::Deflate 2.064 ;
+use IO::Compress::RawDeflate 2.024 ;
-use IO::Compress::Base::Common 2.064 qw(:Status );
-use IO::Compress::Gzip::Constants 2.064 ;
-use IO::Compress::Zlib::Extra 2.064 ;
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status :Parse createSelfTiedObject);
+use IO::Compress::Gzip::Constants 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
BEGIN
{
@@ -23,15 +23,16 @@ BEGIN
{ *noUTF8 = sub {} }
}
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $GzipError);
+require Exporter ;
+
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $GzipError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$GzipError = '' ;
@ISA = qw(Exporter IO::Compress::RawDeflate);
@EXPORT_OK = qw( $GzipError gzip ) ;
%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
-
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
@@ -39,7 +40,7 @@ sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$GzipError);
+ my $obj = createSelfTiedObject($class, \$GzipError);
$obj->_create(undef, @_);
}
@@ -47,7 +48,7 @@ sub new
sub gzip
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$GzipError);
+ my $obj = createSelfTiedObject(undef, \$GzipError);
return $obj->_def(@_);
}
@@ -65,17 +66,17 @@ sub getExtraParams
return (
# zlib behaviour
$self->getZlibParams(),
-
+
# Gzip header fields
- 'minimal' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'comment' => [IO::Compress::Base::Common::Parse_any, undef],
- 'name' => [IO::Compress::Base::Common::Parse_any, undef],
- 'time' => [IO::Compress::Base::Common::Parse_any, undef],
- 'textflag' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'headercrc' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'os_code' => [IO::Compress::Base::Common::Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code],
- 'extrafield'=> [IO::Compress::Base::Common::Parse_any, undef],
- 'extraflags'=> [IO::Compress::Base::Common::Parse_any, undef],
+ 'Minimal' => [0, 1, Parse_boolean, 0],
+ 'Comment' => [0, 1, Parse_any, undef],
+ 'Name' => [0, 1, Parse_any, undef],
+ 'Time' => [0, 1, Parse_any, undef],
+ 'TextFlag' => [0, 1, Parse_boolean, 0],
+ 'HeaderCRC' => [0, 1, Parse_boolean, 0],
+ 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code],
+ 'ExtraField'=> [0, 1, Parse_any, undef],
+ 'ExtraFlags'=> [0, 1, Parse_any, undef],
);
}
@@ -87,24 +88,24 @@ sub ckParams
my $got = shift ;
# gzip always needs crc32
- $got->setValue('crc32' => 1);
+ $got->value('CRC32' => 1);
return 1
- if $got->getValue('merge') ;
+ if $got->value('Merge') ;
- my $strict = $got->getValue('strict') ;
+ my $strict = $got->value('Strict') ;
{
- if (! $got->parsed('time') ) {
+ if (! $got->parsed('Time') ) {
# Modification time defaults to now.
- $got->setValue(time => time) ;
+ $got->value('Time' => time) ;
}
# Check that the Name & Comment don't have embedded NULLs
# Also check that they only contain ISO 8859-1 chars.
- if ($got->parsed('name') && defined $got->getValue('name')) {
- my $name = $got->getValue('name');
+ if ($got->parsed('Name') && defined $got->value('Name')) {
+ my $name = $got->value('Name');
return $self->saveErrorString(undef, "Null Character found in Name",
Z_DATA_ERROR)
@@ -115,8 +116,8 @@ sub ckParams
if $strict && $name =~ /$GZIP_FNAME_INVALID_CHAR_RE/o ;
}
- if ($got->parsed('comment') && defined $got->getValue('comment')) {
- my $comment = $got->getValue('comment');
+ if ($got->parsed('Comment') && defined $got->value('Comment')) {
+ my $comment = $got->value('Comment');
return $self->saveErrorString(undef, "Null Character found in Comment",
Z_DATA_ERROR)
@@ -127,8 +128,8 @@ sub ckParams
if $strict && $comment =~ /$GZIP_FCOMMENT_INVALID_CHAR_RE/o;
}
- if ($got->parsed('os_code') ) {
- my $value = $got->getValue('os_code');
+ if ($got->parsed('OS_Code') ) {
+ my $value = $got->value('OS_Code');
return $self->saveErrorString(undef, "OS_Code must be between 0 and 255, got '$value'")
if $value < 0 || $value > 255 ;
@@ -136,22 +137,22 @@ sub ckParams
}
# gzip only supports Deflate at present
- $got->setValue('method' => Z_DEFLATED) ;
+ $got->value('Method' => Z_DEFLATED) ;
- if ( ! $got->parsed('extraflags')) {
- $got->setValue('extraflags' => 2)
- if $got->getValue('level') == Z_BEST_COMPRESSION ;
- $got->setValue('extraflags' => 4)
- if $got->getValue('level') == Z_BEST_SPEED ;
+ if ( ! $got->parsed('ExtraFlags')) {
+ $got->value('ExtraFlags' => 2)
+ if $got->value('Level') == Z_BEST_SPEED ;
+ $got->value('ExtraFlags' => 4)
+ if $got->value('Level') == Z_BEST_COMPRESSION ;
}
- my $data = $got->getValue('extrafield') ;
+ my $data = $got->value('ExtraField') ;
if (defined $data) {
my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, $strict, 1) ;
return $self->saveErrorString(undef, "Error with ExtraField Parameter: $bad", Z_DATA_ERROR)
if $bad ;
- $got->setValue('extrafield' => $data) ;
+ $got->value('ExtraField', $data) ;
}
}
@@ -177,15 +178,13 @@ sub getFileInfo
my $params = shift;
my $filename = shift ;
- return if IO::Compress::Base::Common::isaScalar($filename);
-
my $defaultTime = (stat($filename))[9] ;
- $params->setValue('name' => $filename)
- if ! $params->parsed('name') ;
+ $params->value('Name' => $filename)
+ if ! $params->parsed('Name') ;
- $params->setValue('time' => $defaultTime)
- if ! $params->parsed('time') ;
+ $params->value('Time' => $defaultTime)
+ if ! $params->parsed('Time') ;
}
@@ -194,28 +193,28 @@ sub mkHeader
my $self = shift ;
my $param = shift ;
- # short-circuit if a minimal header is requested.
- return GZIP_MINIMUM_HEADER if $param->getValue('minimal') ;
+ # stort-circuit if a minimal header is requested.
+ return GZIP_MINIMUM_HEADER if $param->value('Minimal') ;
# METHOD
- my $method = $param->valueOrDefault('method', GZIP_CM_DEFLATED) ;
+ my $method = $param->valueOrDefault('Method', GZIP_CM_DEFLATED) ;
# FLAGS
my $flags = GZIP_FLG_DEFAULT ;
- $flags |= GZIP_FLG_FTEXT if $param->getValue('textflag') ;
- $flags |= GZIP_FLG_FHCRC if $param->getValue('headercrc') ;
- $flags |= GZIP_FLG_FEXTRA if $param->wantValue('extrafield') ;
- $flags |= GZIP_FLG_FNAME if $param->wantValue('name') ;
- $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('comment') ;
+ $flags |= GZIP_FLG_FTEXT if $param->value('TextFlag') ;
+ $flags |= GZIP_FLG_FHCRC if $param->value('HeaderCRC') ;
+ $flags |= GZIP_FLG_FEXTRA if $param->wantValue('ExtraField') ;
+ $flags |= GZIP_FLG_FNAME if $param->wantValue('Name') ;
+ $flags |= GZIP_FLG_FCOMMENT if $param->wantValue('Comment') ;
# MTIME
- my $time = $param->valueOrDefault('time', GZIP_MTIME_DEFAULT) ;
+ my $time = $param->valueOrDefault('Time', GZIP_MTIME_DEFAULT) ;
# EXTRA FLAGS
- my $extra_flags = $param->valueOrDefault('extraflags', GZIP_XFL_DEFAULT);
+ my $extra_flags = $param->valueOrDefault('ExtraFlags', GZIP_XFL_DEFAULT);
# OS CODE
- my $os_code = $param->valueOrDefault('os_code', GZIP_OS_DEFAULT) ;
+ my $os_code = $param->valueOrDefault('OS_Code', GZIP_OS_DEFAULT) ;
my $out = pack("C4 V C C",
@@ -230,13 +229,13 @@ sub mkHeader
# EXTRA
if ($flags & GZIP_FLG_FEXTRA) {
- my $extra = $param->getValue('extrafield') ;
+ my $extra = $param->value('ExtraField') ;
$out .= pack("v", length $extra) . $extra ;
}
# NAME
if ($flags & GZIP_FLG_FNAME) {
- my $name .= $param->getValue('name') ;
+ my $name .= $param->value('Name') ;
$name =~ s/\x00.*$//;
$out .= $name ;
# Terminate the filename with NULL unless it already is
@@ -247,7 +246,7 @@ sub mkHeader
# COMMENT
if ($flags & GZIP_FLG_FCOMMENT) {
- my $comment .= $param->getValue('comment') ;
+ my $comment .= $param->value('Comment') ;
$comment =~ s/\x00.*$//;
$out .= $comment ;
# Terminate the comment with NULL unless it already is
@@ -257,8 +256,7 @@ sub mkHeader
}
# HEADER CRC
- $out .= pack("v", Compress::Raw::Zlib::crc32($out) & 0x00FF )
- if $param->getValue('headercrc') ;
+ $out .= pack("v", crc32($out) & 0x00FF ) if $param->value('HeaderCRC') ;
noUTF8($out);
@@ -343,20 +341,19 @@ section.
use IO::Compress::Gzip qw(gzip $GzipError) ;
- gzip $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ gzip $input => $output [,OPTS]
or die "gzip failed: $GzipError\n";
The functional interface needs Perl5.005 or better.
-=head2 gzip $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 gzip $input => $output [, OPTS]
-C<gzip> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<gzip> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the uncompressed data.
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
It can take one of the following forms:
@@ -364,25 +361,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -391,80 +388,72 @@ contains valid filenames before any data is compressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<gzip> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<gzip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-In addition, if C<$input_filename_or_reference> is a simple filename,
-the default values for
+In addition, if C<$input> is a simple filename, the default values for
the C<Name> and C<Time> options will be sourced from that file.
If you do not want to use these defaults they can be overridden by
explicitly setting the C<Name> and C<Time> options or by setting the
C<Minimal> parameter.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the compressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-compressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-compressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-compressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the compressed data will be pushed onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<gzip> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<gzip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple files/buffers and
-C<$output_filename_or_reference> is a single
+When C<$input> maps to multiple files/buffers and C<$output> is a single
file/buffer the input files/buffers will be stored
-in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
+in C<$output> as a concatenated series of compressed data streams.
=head2 Optional Parameters
@@ -523,8 +512,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any compressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all compressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -802,7 +791,7 @@ and set the CRC16 header field to the CRC of the complete gzip header
except the CRC16 field itself.
B<Note> that gzip files created with the C<HeaderCRC> flag set to 1 cannot
-be read by most, if not all, of the standard gunzip utilities, most
+be read by most, if not all, of the the standard gunzip utilities, most
notably gzip version 1.2.4. You should therefore avoid using this option if
you want to maximize the portability of your gzip files.
@@ -1097,7 +1086,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -1133,7 +1122,7 @@ Usage is
Closes the current compressed data stream and starts a new one.
-OPTS consists of any of the options that are available when creating
+OPTS consists of any of the the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
@@ -1207,6 +1196,8 @@ These symbolic constants are used by the C<Strategy> option in the constructor.
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
@@ -1215,7 +1206,7 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1244,7 +1235,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm
index f6c15c72c9a..8504330d188 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm
@@ -9,7 +9,7 @@ require Exporter;
our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE);
-$VERSION = '2.064';
+$VERSION = '2.024';
@ISA = qw(Exporter);
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm
index 38f7f7dab0e..b97b51c0509 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm
@@ -6,23 +6,45 @@ use strict ;
use warnings;
use bytes;
-use IO::Compress::Base 2.064 ;
-use IO::Compress::Base::Common 2.064 qw(:Status );
-use IO::Compress::Adapter::Deflate 2.064 ;
+
+use IO::Compress::Base 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::Adapter::Deflate 2.024 ;
require Exporter ;
+
our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$RawDeflateError = '';
@ISA = qw(Exporter IO::Compress::Base);
@EXPORT_OK = qw( $RawDeflateError rawdeflate ) ;
-push @EXPORT_OK, @IO::Compress::Adapter::Deflate::EXPORT_OK ;
-
-%EXPORT_TAGS = %IO::Compress::Adapter::Deflate::DEFLATE_CONSTANTS;
+%EXPORT_TAGS = ( flush => [qw{
+ Z_NO_FLUSH
+ Z_PARTIAL_FLUSH
+ Z_SYNC_FLUSH
+ Z_FULL_FLUSH
+ Z_FINISH
+ Z_BLOCK
+ }],
+ level => [qw{
+ Z_NO_COMPRESSION
+ Z_BEST_SPEED
+ Z_BEST_COMPRESSION
+ Z_DEFAULT_COMPRESSION
+ }],
+ strategy => [qw{
+ Z_FILTERED
+ Z_HUFFMAN_ONLY
+ Z_RLE
+ Z_FIXED
+ Z_DEFAULT_STRATEGY
+ }],
+
+ );
{
my %seen;
@@ -38,7 +60,7 @@ push @EXPORT_OK, @IO::Compress::Adapter::Deflate::EXPORT_OK ;
%DEFLATE_CONSTANTS = %EXPORT_TAGS;
-#push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
@@ -48,14 +70,14 @@ sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$RawDeflateError);
+ my $obj = createSelfTiedObject($class, \$RawDeflateError);
return $obj->_create(undef, @_);
}
sub rawdeflate
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$RawDeflateError);
+ my $obj = createSelfTiedObject(undef, \$RawDeflateError);
return $obj->_def(@_);
}
@@ -73,10 +95,10 @@ sub mkComp
my $got = shift ;
my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject(
- $got->getValue('crc32'),
- $got->getValue('adler32'),
- $got->getValue('level'),
- $got->getValue('strategy')
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
);
return $self->saveErrorString(undef, $errstr, $errno)
@@ -113,24 +135,30 @@ sub mkFinalTrailer
sub getExtraParams
{
my $self = shift ;
- return getZlibParams();
+ return $self->getZlibParams();
}
-use IO::Compress::Base::Common 2.064 qw(:Parse);
-use Compress::Raw::Zlib 2.064 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
-our %PARAMS = (
- #'method' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFLATED],
- 'level' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_COMPRESSION],
- 'strategy' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_STRATEGY],
-
- 'crc32' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'adler32' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'merge' => [IO::Compress::Base::Common::Parse_boolean, 0],
- );
-
sub getZlibParams
{
- return %PARAMS;
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ use Compress::Raw::Zlib 2.024 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
+
+
+ return (
+
+ # zlib behaviour
+ #'Method' => [0, 1, Parse_unsigned, Z_DEFLATED],
+ 'Level' => [0, 1, Parse_signed, Z_DEFAULT_COMPRESSION],
+ 'Strategy' => [0, 1, Parse_signed, Z_DEFAULT_STRATEGY],
+
+ 'CRC32' => [0, 1, Parse_boolean, 0],
+ 'ADLER32' => [0, 1, Parse_boolean, 0],
+ 'Merge' => [1, 1, Parse_boolean, 0],
+ );
+
+
}
sub getInverseClass
@@ -289,20 +317,19 @@ section.
use IO::Compress::RawDeflate qw(rawdeflate $RawDeflateError) ;
- rawdeflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ rawdeflate $input => $output [,OPTS]
or die "rawdeflate failed: $RawDeflateError\n";
The functional interface needs Perl5.005 or better.
-=head2 rawdeflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 rawdeflate $input => $output [, OPTS]
-C<rawdeflate> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<rawdeflate> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the uncompressed data.
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
It can take one of the following forms:
@@ -310,25 +337,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -337,72 +364,65 @@ contains valid filenames before any data is compressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<rawdeflate> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<rawdeflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the compressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-compressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-compressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-compressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the compressed data will be pushed onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<rawdeflate> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
-
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<rawdeflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple files/buffers and
-C<$output_filename_or_reference> is a single
+When C<$input> maps to multiple files/buffers and C<$output> is a single
file/buffer the input files/buffers will be stored
-in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
+in C<$output> as a concatenated series of compressed data streams.
=head2 Optional Parameters
@@ -461,8 +481,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any compressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all compressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -841,7 +861,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -877,7 +897,7 @@ Usage is
Closes the current compressed data stream and starts a new one.
-OPTS consists of any of the options that are available when creating
+OPTS consists of any of the the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
@@ -951,6 +971,8 @@ These symbolic constants are used by the C<Strategy> option in the constructor.
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
@@ -959,7 +981,7 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -988,7 +1010,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm
index a8645b346af..5e37d78f97d 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm
@@ -4,45 +4,40 @@ use strict ;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status );
-use IO::Compress::RawDeflate 2.064 ();
-use IO::Compress::Adapter::Deflate 2.064 ;
-use IO::Compress::Adapter::Identity 2.064 ;
-use IO::Compress::Zlib::Extra 2.064 ;
-use IO::Compress::Zip::Constants 2.064 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::RawDeflate 2.024 ;
+use IO::Compress::Adapter::Deflate 2.024 ;
+use IO::Compress::Adapter::Identity 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
+use IO::Compress::Zip::Constants 2.024 ;
-use File::Spec();
-use Config;
-
-use Compress::Raw::Zlib 2.064 ();
+use Compress::Raw::Zlib 2.024 qw(crc32) ;
BEGIN
{
eval { require IO::Compress::Adapter::Bzip2 ;
- import IO::Compress::Adapter::Bzip2 2.064 ;
+ import IO::Compress::Adapter::Bzip2 2.024 ;
require IO::Compress::Bzip2 ;
- import IO::Compress::Bzip2 2.064 ;
- } ;
-
- eval { require IO::Compress::Adapter::Lzma ;
- import IO::Compress::Adapter::Lzma 2.064 ;
- require IO::Compress::Lzma ;
- import IO::Compress::Lzma 2.064 ;
+ import IO::Compress::Bzip2 2.024 ;
} ;
+# eval { require IO::Compress::Adapter::Lzma ;
+# import IO::Compress::Adapter::Lzma 2.020 ;
+# require IO::Compress::Lzma ;
+# import IO::Compress::Lzma 2.024 ;
+# } ;
}
require Exporter ;
-our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $ZipError);
+our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $ZipError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$ZipError = '';
@ISA = qw(Exporter IO::Compress::RawDeflate);
@EXPORT_OK = qw( $ZipError zip ) ;
%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
-
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
$EXPORT_TAGS{zip_method} = [qw( ZIP_CM_STORE ZIP_CM_DEFLATE ZIP_CM_BZIP2 ZIP_CM_LZMA)];
@@ -54,57 +49,16 @@ sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$ZipError);
+ my $obj = createSelfTiedObject($class, \$ZipError);
$obj->_create(undef, @_);
-
}
sub zip
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$ZipError);
+ my $obj = createSelfTiedObject(undef, \$ZipError);
return $obj->_def(@_);
}
-sub isMethodAvailable
-{
- my $method = shift;
-
- # Store & Deflate are always available
- return 1
- if $method == ZIP_CM_STORE || $method == ZIP_CM_DEFLATE ;
-
- return 1
- if $method == ZIP_CM_BZIP2 and
- defined $IO::Compress::Adapter::Bzip2::VERSION;
-
- return 1
- if $method == ZIP_CM_LZMA and
- defined $IO::Compress::Adapter::Lzma::VERSION;
-
- return 0;
-}
-
-sub beforePayload
-{
- my $self = shift ;
-
- if (*$self->{ZipData}{Sparse} ) {
- my $inc = 1024 * 100 ;
- my $NULLS = ("\x00" x $inc) ;
- my $sparse = *$self->{ZipData}{Sparse} ;
- *$self->{CompSize}->add( $sparse );
- *$self->{UnCompSize}->add( $sparse );
-
- *$self->{FH}->seek($sparse, IO::Handle::SEEK_CUR);
-
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32($NULLS, *$self->{ZipData}{CRC32})
- for 1 .. int $sparse / $inc;
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(substr($NULLS, 0, $sparse % $inc),
- *$self->{ZipData}{CRC32})
- if $sparse % $inc;
- }
-}
-
sub mkComp
{
my $self = shift ;
@@ -114,33 +68,31 @@ sub mkComp
if (*$self->{ZipData}{Method} == ZIP_CM_STORE) {
($obj, $errstr, $errno) = IO::Compress::Adapter::Identity::mkCompObject(
- $got->getValue('level'),
- $got->getValue('strategy')
+ $got->value('Level'),
+ $got->value('Strategy')
);
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef);
+ *$self->{ZipData}{CRC32} = crc32(undef);
}
elsif (*$self->{ZipData}{Method} == ZIP_CM_DEFLATE) {
($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject(
- $got->getValue('crc32'),
- $got->getValue('adler32'),
- $got->getValue('level'),
- $got->getValue('strategy')
+ $got->value('CRC32'),
+ $got->value('Adler32'),
+ $got->value('Level'),
+ $got->value('Strategy')
);
}
elsif (*$self->{ZipData}{Method} == ZIP_CM_BZIP2) {
($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject(
- $got->getValue('blocksize100k'),
- $got->getValue('workfactor'),
- $got->getValue('verbosity')
+ $got->value('BlockSize100K'),
+ $got->value('WorkFactor'),
+ $got->value('Verbosity')
);
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef);
- }
- elsif (*$self->{ZipData}{Method} == ZIP_CM_LZMA) {
- ($obj, $errstr, $errno) = IO::Compress::Adapter::Lzma::mkRawZipCompObject($got->getValue('preset'),
- $got->getValue('extreme'),
- );
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef);
+ *$self->{ZipData}{CRC32} = crc32(undef);
}
+# elsif (*$self->{ZipData}{Method} == ZIP_CM_LZMA) {
+# ($obj, $errstr, $errno) = IO::Compress::Adapter::Lzma::mkCompObject();
+# *$self->{ZipData}{CRC32} = crc32(undef);
+# }
return $self->saveErrorString(undef, $errstr, $errno)
if ! defined $obj;
@@ -174,103 +126,41 @@ sub filterUncompressed
*$self->{ZipData}{CRC32} = *$self->{Compress}->crc32();
}
else {
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(${$_[0]}, *$self->{ZipData}{CRC32});
+ *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32});
}
}
-sub canonicalName
-{
- # This sub is derived from Archive::Zip::_asZipDirName
-
- # Return the normalized name as used in a zip file (path
- # separators become slashes, etc.).
- # Will translate internal slashes in path components (i.e. on Macs) to
- # underscores. Discards volume names.
- # When $forceDir is set, returns paths with trailing slashes
- #
- # input output
- # . '.'
- # ./a a
- # ./a/b a/b
- # ./a/b/ a/b
- # a/b/ a/b
- # /a/b/ a/b
- # c:\a\b\c.doc a/b/c.doc # on Windows
- # "i/o maps:whatever" i_o maps/whatever # on Macs
-
- my $name = shift;
- my $forceDir = shift ;
-
- my ( $volume, $directories, $file ) =
- File::Spec->splitpath( File::Spec->canonpath($name), $forceDir );
-
- my @dirs = map { $_ =~ s{/}{_}g; $_ }
- File::Spec->splitdir($directories);
-
- if ( @dirs > 0 ) { pop (@dirs) if $dirs[-1] eq '' } # remove empty component
- push @dirs, defined($file) ? $file : '' ;
-
- my $normalised_path = join '/', @dirs;
-
- # Leading directory separators should not be stored in zip archives.
- # Example:
- # C:\a\b\c\ a/b/c
- # C:\a\b\c.txt a/b/c.txt
- # /a/b/c/ a/b/c
- # /a/b/c.txt a/b/c.txt
- $normalised_path =~ s{^/}{}; # remove leading separator
-
- return $normalised_path;
-}
-
-
sub mkHeader
{
my $self = shift;
my $param = shift ;
+
*$self->{ZipData}{LocalHdrOffset} = U64::clone(*$self->{ZipData}{Offset});
-
- my $comment = '';
- $comment = $param->valueOrDefault('comment') ;
my $filename = '';
- $filename = $param->valueOrDefault('name') ;
+ $filename = $param->value('Name') || '';
- $filename = canonicalName($filename)
- if length $filename && $param->getValue('canonicalname') ;
-
- if (defined *$self->{ZipData}{FilterName} ) {
- local *_ = \$filename ;
- &{ *$self->{ZipData}{FilterName} }() ;
- }
-
-# if ( $param->getValue('utf8') ) {
-# require Encode ;
-# $filename = Encode::encode_utf8($filename)
-# if length $filename ;
-# $comment = Encode::encode_utf8($comment)
-# if length $comment ;
-# }
+ my $comment = '';
+ $comment = $param->value('Comment') || '';
my $hdr = '';
- my $time = _unixToDosTime($param->getValue('time'));
+ my $time = _unixToDosTime($param->value('Time'));
my $extra = '';
my $ctlExtra = '';
my $empty = 0;
- my $osCode = $param->getValue('os_code') ;
+ my $osCode = $param->value('OS_Code') ;
my $extFileAttr = 0 ;
# This code assumes Unix.
- # TODO - revisit this
- $extFileAttr = 0100644 << 16
+ $extFileAttr = 0666 << 16
if $osCode == ZIP_OS_CODE_UNIX ;
if (*$self->{ZipData}{Zip64}) {
- $empty = IO::Compress::Base::Common::MAX32;
+ $empty = 0xFFFFFFFF;
my $x = '';
$x .= pack "V V", 0, 0 ; # uncompressedLength
@@ -278,58 +168,42 @@ sub mkHeader
$extra .= IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_ZIP64, $x);
}
- if (! $param->getValue('minimal')) {
- if ($param->parsed('mtime'))
+ if (! $param->value('Minimal')) {
+ if (defined $param->value('exTime'))
{
- $extra .= mkExtendedTime($param->getValue('mtime'),
- $param->getValue('atime'),
- $param->getValue('ctime'));
+ $extra .= mkExtendedTime($param->value('MTime'),
+ $param->value('ATime'),
+ $param->value('CTime'));
- $ctlExtra .= mkExtendedTime($param->getValue('mtime'));
+ $ctlExtra .= mkExtendedTime($param->value('MTime'));
}
- if ( $osCode == ZIP_OS_CODE_UNIX )
+ if ( $param->value('UID') && $osCode == ZIP_OS_CODE_UNIX)
{
- if ( $param->getValue('want_exunixn') )
- {
- my $ux3 = mkUnixNExtra( @{ $param->getValue('want_exunixn') });
- $extra .= $ux3;
- $ctlExtra .= $ux3;
- }
-
- if ( $param->getValue('exunix2') )
- {
- $extra .= mkUnix2Extra( @{ $param->getValue('exunix2') });
- $ctlExtra .= mkUnix2Extra();
- }
+ $extra .= mkUnix2Extra( $param->value('UID'), $param->value('GID'));
+ $ctlExtra .= mkUnix2Extra();
}
- $extFileAttr = $param->getValue('extattr')
- if defined $param->getValue('extattr') ;
+ $extFileAttr = $param->value('ExtAttr')
+ if defined $param->value('ExtAttr') ;
- $extra .= $param->getValue('extrafieldlocal')
- if defined $param->getValue('extrafieldlocal');
+ $extra .= $param->value('ExtraFieldLocal')
+ if defined $param->value('ExtraFieldLocal');
- $ctlExtra .= $param->getValue('extrafieldcentral')
- if defined $param->getValue('extrafieldcentral');
+ $ctlExtra .= $param->value('ExtraFieldCentral')
+ if defined $param->value('ExtraFieldCentral');
}
- my $method = *$self->{ZipData}{Method} ;
my $gpFlag = 0 ;
$gpFlag |= ZIP_GP_FLAG_STREAMING_MASK
if *$self->{ZipData}{Stream} ;
- $gpFlag |= ZIP_GP_FLAG_LZMA_EOS_PRESENT
- if $method == ZIP_CM_LZMA ;
-
-# $gpFlag |= ZIP_GP_FLAG_LANGUAGE_ENCODING
-# if $param->getValue('utf8') && (length($filename) || length($comment));
+ my $method = *$self->{ZipData}{Method} ;
my $version = $ZIP_CM_MIN_VERSIONS{$method};
$version = ZIP64_MIN_VERSION
if ZIP64_MIN_VERSION > $version && *$self->{ZipData}{Zip64};
-
- my $madeBy = ($param->getValue('os_code') << 8) + $version;
+ my $madeBy = ($param->value('OS_Code') << 8) + $version;
my $extract = $version;
*$self->{ZipData}{Version} = $version;
@@ -337,7 +211,7 @@ sub mkHeader
my $ifa = 0;
$ifa |= ZIP_IFA_TEXT_MASK
- if $param->getValue('textflag');
+ if $param->value('TextFlag');
$hdr .= pack "V", ZIP_LOCAL_HDR_SIG ; # signature
$hdr .= pack 'v', $extract ; # extract Version & OS
@@ -390,7 +264,7 @@ sub mkHeader
# offset to local hdr
if (*$self->{ZipData}{LocalHdrOffset}->is64bit() ) {
- $ctl .= pack 'V', IO::Compress::Base::Common::MAX32 ;
+ $ctl .= pack 'V', 0xFFFFFFFF ;
}
else {
$ctl .= *$self->{ZipData}{LocalHdrOffset}->getPacked_V32() ;
@@ -400,11 +274,10 @@ sub mkHeader
$ctl .= $ctlExtra ;
$ctl .= $comment ;
- *$self->{ZipData}{Offset}->add32(length $hdr) ;
+ *$self->{ZipData}{Offset}->add(length $hdr) ;
*$self->{ZipData}{CentralHeader} = $ctl;
-
return $hdr;
}
@@ -434,7 +307,6 @@ sub mkTrailer
my $data = $crc32 . $sizes ;
-
my $xtrasize = *$self->{UnCompSize}->getPacked_V64() ; # Uncompressed size
$xtrasize .= *$self->{CompSize}->getPacked_V64() ; # Compressed size
@@ -459,14 +331,14 @@ sub mkTrailer
my $x = '';
# uncompressed length
- if (*$self->{UnCompSize}->isAlmost64bit() || *$self->{ZipData}{Zip64} > 1) {
+ if (*$self->{UnCompSize}->is64bit() ) {
$x .= *$self->{UnCompSize}->getPacked_V64() ;
} else {
substr($ctl, 24, 4) = *$self->{UnCompSize}->getPacked_V32() ;
}
# compressed length
- if (*$self->{CompSize}->isAlmost64bit() || *$self->{ZipData}{Zip64} > 1) {
+ if (*$self->{CompSize}->is64bit() ) {
$x .= *$self->{CompSize}->getPacked_V64() ;
} else {
substr($ctl, 20, 4) = *$self->{CompSize}->getPacked_V32() ;
@@ -488,7 +360,7 @@ sub mkTrailer
*$self->{ZipData}{AnyZip64} = 1;
}
- *$self->{ZipData}{Offset}->add32(length($hdr));
+ *$self->{ZipData}{Offset}->add(length($hdr));
*$self->{ZipData}{Offset}->add( *$self->{CompSize} );
push @{ *$self->{ZipData}{CentralDir} }, $ctl ;
@@ -498,17 +370,13 @@ sub mkTrailer
sub mkFinalTrailer
{
my $self = shift ;
-
+
my $comment = '';
$comment = *$self->{ZipData}{ZipComment} ;
my $cd_offset = *$self->{ZipData}{Offset}->get32bit() ; # offset to start central dir
my $entries = @{ *$self->{ZipData}{CentralDir} };
-
- *$self->{ZipData}{AnyZip64} = 1
- if *$self->{ZipData}{Offset}->is64bit || $entries >= 0xFFFF ;
-
my $cd = join '', @{ *$self->{ZipData}{CentralDir} };
my $cd_len = length $cd ;
@@ -531,15 +399,15 @@ sub mkFinalTrailer
. U64::pack_V64(length $z64e)
. $z64e ;
- *$self->{ZipData}{Offset}->add32(length $cd) ;
+ *$self->{ZipData}{Offset}->add(length $cd) ;
$z64e .= pack "V", ZIP64_END_CENTRAL_LOC_HDR_SIG; # signature
$z64e .= pack 'V', 0 ; # number of disk with central dir
$z64e .= *$self->{ZipData}{Offset}->getPacked_V64() ; # offset to end zip64 central dir
$z64e .= pack 'V', 1 ; # Total number of disks
- $cd_offset = IO::Compress::Base::Common::MAX32 ;
- $cd_len = IO::Compress::Base::Common::MAX32 if IO::Compress::Base::Common::isGeMax32 $cd_len ;
+ $cd_offset = 0xFFFFFFFF ;
+ $cd_len = 0xFFFFFFFF if $cd_len >= 0xFFFFFFFF ;
$entries = 0xFFFF if $entries >= 0xFFFF ;
}
@@ -562,47 +430,43 @@ sub ckParams
my $self = shift ;
my $got = shift;
- $got->setValue('crc32' => 1);
+ $got->value('CRC32' => 1);
- if (! $got->parsed('time') ) {
+ if (! $got->parsed('Time') ) {
# Modification time defaults to now.
- $got->setValue('time' => time) ;
+ $got->value('Time' => time) ;
}
- if ($got->parsed('extime') ) {
- my $timeRef = $got->getValue('extime');
+ if ($got->parsed('exTime') ) {
+ my $timeRef = $got->value('exTime');
if ( defined $timeRef) {
return $self->saveErrorString(undef, "exTime not a 3-element array ref")
if ref $timeRef ne 'ARRAY' || @$timeRef != 3;
}
- $got->setValue("mtime", $timeRef->[1]);
- $got->setValue("atime", $timeRef->[0]);
- $got->setValue("ctime", $timeRef->[2]);
+ $got->value("MTime", $timeRef->[1]);
+ $got->value("ATime", $timeRef->[0]);
+ $got->value("CTime", $timeRef->[2]);
}
- # Unix2/3 Extended Attribute
- for my $name (qw(exunix2 exunixn))
- {
- if ($got->parsed($name) ) {
- my $idRef = $got->getValue($name);
- if ( defined $idRef) {
- return $self->saveErrorString(undef, "$name not a 2-element array ref")
- if ref $idRef ne 'ARRAY' || @$idRef != 2;
- }
-
- $got->setValue("uid", $idRef->[0]);
- $got->setValue("gid", $idRef->[1]);
- $got->setValue("want_$name", $idRef);
+ # Unix2 Extended Attribute
+ if ($got->parsed('exUnix2') ) {
+ my $timeRef = $got->value('exUnix2');
+ if ( defined $timeRef) {
+ return $self->saveErrorString(undef, "exUnix2 not a 2-element array ref")
+ if ref $timeRef ne 'ARRAY' || @$timeRef != 2;
}
+
+ $got->value("UID", $timeRef->[0]);
+ $got->value("GID", $timeRef->[1]);
}
*$self->{ZipData}{AnyZip64} = 1
- if $got->getValue('zip64');
- *$self->{ZipData}{Zip64} = $got->getValue('zip64');
- *$self->{ZipData}{Stream} = $got->getValue('stream');
+ if $got->value('Zip64');
+ *$self->{ZipData}{Zip64} = $got->value('Zip64');
+ *$self->{ZipData}{Stream} = $got->value('Stream');
- my $method = $got->getValue('method');
+ my $method = $got->value('Method');
return $self->saveErrorString(undef, "Unknown Method '$method'")
if ! defined $ZIP_CM_MIN_VERSIONS{$method};
@@ -611,22 +475,23 @@ sub ckParams
! defined $IO::Compress::Adapter::Bzip2::VERSION;
return $self->saveErrorString(undef, "Lzma not available")
- if $method == ZIP_CM_LZMA
- and ! defined $IO::Compress::Adapter::Lzma::VERSION;
+ if $method == ZIP_CM_LZMA ;
+ #and
+ #! defined $IO::Compress::Adapter::Lzma::VERSION;
*$self->{ZipData}{Method} = $method;
- *$self->{ZipData}{ZipComment} = $got->getValue('zipcomment') ;
+ *$self->{ZipData}{ZipComment} = $got->value('ZipComment') ;
- for my $name (qw( extrafieldlocal extrafieldcentral ))
+ for my $name (qw( ExtraFieldLocal ExtraFieldCentral ))
{
- my $data = $got->getValue($name) ;
+ my $data = $got->value($name) ;
if (defined $data) {
my $bad = IO::Compress::Zlib::Extra::parseExtraField($data, 1, 0) ;
return $self->saveErrorString(undef, "Error with $name Parameter: $bad")
if $bad ;
- $got->setValue($name, $data) ;
+ $got->value($name, $data) ;
}
}
@@ -634,28 +499,9 @@ sub ckParams
if defined $IO::Compress::Bzip2::VERSION
and ! IO::Compress::Bzip2::ckParams($self, $got);
- if ($got->parsed('sparse') ) {
- *$self->{ZipData}{Sparse} = $got->getValue('sparse') ;
- *$self->{ZipData}{Method} = ZIP_CM_STORE;
- }
-
- if ($got->parsed('filtername')) {
- my $v = $got->getValue('filtername') ;
- *$self->{ZipData}{FilterName} = $v
- if ref $v eq 'CODE' ;
- }
-
return 1 ;
}
-sub outputPayload
-{
- my $self = shift ;
- return 1 if *$self->{ZipData}{Sparse} ;
- return $self->output(@_);
-}
-
-
#sub newHeader
#{
# my $self = shift ;
@@ -663,53 +509,44 @@ sub outputPayload
# return $self->mkHeader(*$self->{Got});
#}
+sub getExtraParams
+{
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ use Compress::Raw::Zlib 2.024 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY);
-our %PARAMS = (
- 'stream' => [IO::Compress::Base::Common::Parse_boolean, 1],
- #'store' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'method' => [IO::Compress::Base::Common::Parse_unsigned, ZIP_CM_DEFLATE],
+ my @Bzip2 = ();
+
+ @Bzip2 = IO::Compress::Bzip2::getExtraParams($self)
+ if defined $IO::Compress::Bzip2::VERSION;
+
+ return (
+ # zlib behaviour
+ $self->getZlibParams(),
+
+ 'Stream' => [1, 1, Parse_boolean, 1],
+ #'Store' => [0, 1, Parse_boolean, 0],
+ 'Method' => [0, 1, Parse_unsigned, ZIP_CM_DEFLATE],
# # Zip header fields
- 'minimal' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'zip64' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'comment' => [IO::Compress::Base::Common::Parse_any, ''],
- 'zipcomment'=> [IO::Compress::Base::Common::Parse_any, ''],
- 'name' => [IO::Compress::Base::Common::Parse_any, ''],
- 'filtername'=> [IO::Compress::Base::Common::Parse_code, undef],
- 'canonicalname'=> [IO::Compress::Base::Common::Parse_boolean, 0],
-# 'utf8' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'time' => [IO::Compress::Base::Common::Parse_any, undef],
- 'extime' => [IO::Compress::Base::Common::Parse_any, undef],
- 'exunix2' => [IO::Compress::Base::Common::Parse_any, undef],
- 'exunixn' => [IO::Compress::Base::Common::Parse_any, undef],
- 'extattr' => [IO::Compress::Base::Common::Parse_any,
- $Compress::Raw::Zlib::gzip_os_code == 3
- ? 0100644 << 16
- : 0],
- 'os_code' => [IO::Compress::Base::Common::Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code],
+ 'Minimal' => [0, 1, Parse_boolean, 0],
+ 'Zip64' => [0, 1, Parse_boolean, 0],
+ 'Comment' => [0, 1, Parse_any, ''],
+ 'ZipComment'=> [0, 1, Parse_any, ''],
+ 'Name' => [0, 1, Parse_any, ''],
+ 'Time' => [0, 1, Parse_any, undef],
+ 'exTime' => [0, 1, Parse_any, undef],
+ 'exUnix2' => [0, 1, Parse_any, undef],
+ 'ExtAttr' => [0, 1, Parse_any, 0],
+ 'OS_Code' => [0, 1, Parse_unsigned, $Compress::Raw::Zlib::gzip_os_code],
- 'textflag' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'extrafieldlocal' => [IO::Compress::Base::Common::Parse_any, undef],
- 'extrafieldcentral'=> [IO::Compress::Base::Common::Parse_any, undef],
-
- # Lzma
- 'preset' => [IO::Compress::Base::Common::Parse_unsigned, 6],
- 'extreme' => [IO::Compress::Base::Common::Parse_boolean, 0],
-
- # For internal use only
- 'sparse' => [IO::Compress::Base::Common::Parse_unsigned, 0],
+ 'TextFlag' => [0, 1, Parse_boolean, 0],
+ 'ExtraFieldLocal' => [0, 1, Parse_any, undef],
+ 'ExtraFieldCentral'=> [0, 1, Parse_any, undef],
- IO::Compress::RawDeflate::getZlibParams(),
- defined $IO::Compress::Bzip2::VERSION
- ? IO::Compress::Bzip2::getExtraParams()
- : ()
-
-
- );
-
-sub getExtraParams
-{
- return %PARAMS ;
+ @Bzip2,
+ );
}
sub getInverseClass
@@ -724,60 +561,29 @@ sub getFileInfo
my $params = shift;
my $filename = shift ;
- if (IO::Compress::Base::Common::isaScalar($filename))
- {
- $params->setValue(zip64 => 1)
- if IO::Compress::Base::Common::isGeMax32 length (${ $filename }) ;
-
- return ;
- }
-
- my ($mode, $uid, $gid, $size, $atime, $mtime, $ctime) ;
- if ( $params->parsed('storelinks') )
- {
- ($mode, $uid, $gid, $size, $atime, $mtime, $ctime)
- = (lstat($filename))[2, 4,5,7, 8,9,10] ;
- }
- else
- {
- ($mode, $uid, $gid, $size, $atime, $mtime, $ctime)
- = (stat($filename))[2, 4,5,7, 8,9,10] ;
- }
-
- $params->setValue(textflag => -T $filename )
- if ! $params->parsed('textflag');
-
- $params->setValue(zip64 => 1)
- if IO::Compress::Base::Common::isGeMax32 $size ;
+ my ($mode, $uid, $gid, $atime, $mtime, $ctime)
+ = (stat($filename))[2, 4,5, 8,9,10] ;
- $params->setValue('name' => $filename)
- if ! $params->parsed('name') ;
+ $params->value('Name' => $filename)
+ if ! $params->parsed('Name') ;
- $params->setValue('time' => $mtime)
- if ! $params->parsed('time') ;
+ $params->value('Time' => $mtime)
+ if ! $params->parsed('Time') ;
- if ( ! $params->parsed('extime'))
+ if ( ! $params->parsed('exTime'))
{
- $params->setValue('mtime' => $mtime) ;
- $params->setValue('atime' => $atime) ;
- $params->setValue('ctime' => undef) ; # No Creation time
- # TODO - see if can fillout creation time on non-Unix
+ $params->value('MTime' => $mtime) ;
+ $params->value('ATime' => $atime) ;
+ $params->value('CTime' => undef) ; # No Creation time
+ $params->value("exTime", [$mtime, $atime, undef]);
}
# NOTE - Unix specific code alert
- if (! $params->parsed('extattr'))
- {
- use Fcntl qw(:mode) ;
- my $attr = $mode << 16;
- $attr |= ZIP_A_RONLY if ($mode & S_IWRITE) == 0 ;
- $attr |= ZIP_A_DIR if ($mode & S_IFMT ) == S_IFDIR ;
-
- $params->setValue('extattr' => $attr);
- }
+ $params->value('ExtAttr' => $mode << 16)
+ if ! $params->parsed('ExtAttr');
- $params->setValue('want_exunixn', [$uid, $gid]);
- $params->setValue('uid' => $uid) ;
- $params->setValue('gid' => $gid) ;
+ $params->value('UID' => $uid) ;
+ $params->value('GID' => $gid) ;
}
@@ -816,29 +622,11 @@ sub mkUnix2Extra
$ids);
}
-sub mkUnixNExtra
-{
- my $uid = shift;
- my $gid = shift;
-
- # Assumes UID/GID are 32-bit
- my $ids ;
- $ids .= pack "C", 1; # version
- $ids .= pack "C", $Config{uidsize};
- $ids .= pack "V", $uid;
- $ids .= pack "C", $Config{gidsize};
- $ids .= pack "V", $gid;
-
- return IO::Compress::Zlib::Extra::mkSubField(ZIP_EXTRA_ID_INFO_ZIP_UNIXN,
- $ids);
-}
-
# from Archive::Zip
sub _unixToDosTime # Archive::Zip::Member
{
my $time_t = shift;
-
# TODO - add something to cope with unix time < 1980
my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time_t);
my $dt = 0;
@@ -914,14 +702,11 @@ zip files and buffers. It is not a general-purpose file archiver. If that
is what you want, check out C<Archive::Zip>.
At present three compression methods are supported by IO::Compress::Zip,
-namely Store (no compression at all), Deflate, Bzip2 and LZMA.
+namely Store (no compression at all), Deflate and Bzip2.
Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must
be installed.
-Note that to create LZMA content, the module C<IO::Compress::Lzma> must
-be installed.
-
For reading zip files/buffers, see the companion module
L<IO::Uncompress::Unzip|IO::Uncompress::Unzip>.
@@ -934,20 +719,19 @@ section.
use IO::Compress::Zip qw(zip $ZipError) ;
- zip $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ zip $input => $output [,OPTS]
or die "zip failed: $ZipError\n";
The functional interface needs Perl5.005 or better.
-=head2 zip $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 zip $input => $output [, OPTS]
-C<zip> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<zip> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the uncompressed data.
+The parameter, C<$input>, is used to define the source of
+the uncompressed data.
It can take one of the following forms:
@@ -955,25 +739,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -982,80 +766,72 @@ contains valid filenames before any data is compressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<zip> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<zip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-In addition, if C<$input_filename_or_reference> is a simple filename,
-the default values for
-the C<Name>, C<Time>, C<TextFlag>, C<ExtAttr>, C<exUnixN> and C<exTime> options will be sourced from that file.
+In addition, if C<$input> is a simple filename, the default values for
+the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options will be sourced from that file.
If you do not want to use these defaults they can be overridden by
-explicitly setting the C<Name>, C<Time>, C<TextFlag>, C<ExtAttr>, C<exUnixN> and C<exTime> options or by setting the
+explicitly setting the C<Name>, C<Time>, C<ExtAttr> and C<exTime> options or by setting the
C<Minimal> parameter.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the compressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+compressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-compressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the compressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-compressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the compressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-compressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the compressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the compressed data will be pushed onto the array.
+If C<$output> is an array reference, the compressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<zip> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<zip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple files/buffers and
-C<$output_filename_or_reference> is a single
+When C<$input> maps to multiple files/buffers and C<$output> is a single
file/buffer the input files/buffers will each be stored
-in C<$output_filename_or_reference> as a distinct entry.
+in C<$output> as a distinct entry.
=head2 Optional Parameters
@@ -1114,8 +890,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any compressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all compressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all compressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -1156,32 +932,28 @@ compressed data to a buffer, C<$buffer>.
zip $input => \$buffer
or die "zip failed: $ZipError\n";
-To create a zip file, C<output.zip>, that contains the compressed contents
-of the files C<alpha.txt> and C<beta.txt>
+To compress all files in the directory "/my/home" that match "*.txt"
+and store the compressed data in the same directory
use strict ;
use warnings ;
use IO::Compress::Zip qw(zip $ZipError) ;
- zip [ 'alpha.txt', 'beta.txt' ] => 'output.zip'
+ zip '</my/home/*.txt>' => '<*.zip>'
or die "zip failed: $ZipError\n";
-Alternatively, rather than having to explicitly name each of the files that
-you want to compress, you could use a fileglob to select all the C<txt>
-files in the current directory, as follows
+and if you want to compress each file one at a time, this will do the trick
use strict ;
use warnings ;
use IO::Compress::Zip qw(zip $ZipError) ;
- my @files = <*.txt>;
- zip \@files => 'output.zip'
- or die "zip failed: $ZipError\n";
-
-or more succinctly
-
- zip [ <*.txt> ] => 'output.zip'
- or die "zip failed: $ZipError\n";
+ for my $input ( glob "/my/home/*.txt" )
+ {
+ my $output = "$input.zip" ;
+ zip $input => $output
+ or die "Error compressing '$input': $ZipError\n";
+ }
=head1 OO Interface
@@ -1279,76 +1051,15 @@ This parameter defaults to 0.
=item C<< Name => $string >>
-Stores the contents of C<$string> in the zip filename header field.
-
-If C<Name> is not specified and the C<$input> parameter is a filename, the
-value of C<$input> will be used for the zip filename header field.
-
-If C<Name> is not specified and the C<$input> parameter is not a filename,
-no zip filename field will be created.
-
-Note that both the C<CanonicalName> and C<FilterName> options
-can modify the value used for the zip filename header field.
-
-=item C<< CanonicalName => 0|1 >>
-
-This option controls whether the filename field in the zip header is
-I<normalized> into Unix format before being written to the zip file.
-
-It is recommended that you enable this option unless you really need
-to create a non-standard Zip file.
-
-This is what APPNOTE.TXT has to say on what should be stored in the zip
-filename header field.
-
- The name of the file, with optional relative path.
- The path stored should not contain a drive or
- device letter, or a leading slash. All slashes
- should be forward slashes '/' as opposed to
- backwards slashes '\' for compatibility with Amiga
- and UNIX file systems etc.
-
-This option defaults to B<false>.
-
-=item C<< FilterName => sub { ... } >>
-
-This option allow the filename field in the zip header to be modified
-before it is written to the zip file.
-
-This option takes a parameter that must be a reference to a sub. On entry
-to the sub the C<$_> variable will contain the name to be filtered. If no
-filename is available C<$_> will contain an empty string.
-
-The value of C<$_> when the sub returns will be stored in the filename
-header field.
-
-Note that if C<CanonicalName> is enabled, a
-normalized filename will be passed to the sub.
-
-If you use C<FilterName> to modify the filename, it is your responsibility
-to keep the filename in Unix format.
-
-Although this option can be used with the OO interface, it is of most use
-with the one-shot interface. For example, the code below shows how
-C<FilterName> can be used to remove the path component from a series of
-filenames before they are stored in C<$zipfile>.
-
- sub compressTxtFiles
- {
- my $zipfile = shift ;
- my $dir = shift ;
-
- zip [ <$dir/*.txt> ] => $zipfile,
- FilterName => sub { s[^$dir/][] } ;
- }
+Stores the contents of C<$string> in the zip filename header field. If
+C<Name> is not specified, no zip filename field will be created.
=item C<< Time => $number >>
Sets the last modified time field in the zip header to $number.
This field defaults to the time the C<IO::Compress::Zip> object was created
-if this option is not specified and the C<$input> parameter is not a
-filename.
+if this option is not specified.
=item C<< ExtAttr => $attr >>
@@ -1357,10 +1068,10 @@ header of the zip file. This is a 4 byte field.
If you are running a Unix derivative this value defaults to
- 0100644 << 16
+ 0666 << 16
This should allow read/write access to any files that are extracted from
-the zip file/buffer`.
+the zip file/buffer.
For all other systems it defaults to 0.
@@ -1387,37 +1098,18 @@ By default no extended time field is created.
=item C<< exUnix2 => [$uid, $gid] >>
This option expects an array reference with exactly two elements: C<$uid>
-and C<$gid>. These values correspond to the numeric User ID (UID) and Group ID
-(GID) of the owner of the files respectively.
+and C<$gid>. These values correspond to the numeric user ID and group ID
+of the owner of the files respectively.
When the C<exUnix2> option is present it will trigger the creation of a
-Unix2 extra field (ID is "Ux") in the local zip header. This will be populated
-with C<$uid> and C<$gid>. An empty Unix2 extra field will also
-be created in the central zip header.
-
-Note - The UID & GID are stored as 16-bit
-integers in the "Ux" field. Use C<< exUnixN >> if your UID or GID are
-32-bit.
+Unix2 extra field (ID is "Ux") in the local zip. This will be populated
+with C<$uid> and C<$gid>. In addition an empty Unix2 extra field will also
+be created in the central zip header
If the C<Minimal> option is set to true, this option will be ignored.
By default no Unix2 extra field is created.
-=item C<< exUnixN => [$uid, $gid] >>
-
-This option expects an array reference with exactly two elements: C<$uid>
-and C<$gid>. These values correspond to the numeric User ID (UID) and Group ID
-(GID) of the owner of the files respectively.
-
-When the C<exUnixN> option is present it will trigger the creation of a
-UnixN extra field (ID is "ux") in both the local and central zip headers.
-This will be populated with C<$uid> and C<$gid>.
-The UID & GID are stored as 32-bit integers.
-
-If the C<Minimal> option is set to true, this option will be ignored.
-
-By default no UnixN extra field is created.
-
=item C<< Comment => $comment >>
Stores the contents of C<$comment> in the Central File Header of
@@ -1434,12 +1126,12 @@ By default, no comment field is written to the zip file.
=item C<< Method => $method >>
-Controls which compression method is used. At present four compression
-methods are supported, namely Store (no compression at all), Deflate,
-Bzip2 and Lzma.
+Controls which compression method is used. At present three compression
+methods are supported, namely Store (no compression at all), Deflate and
+Bzip2.
-The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE, ZIP_CM_BZIP2 and ZIP_CM_LZMA
-are used to select the compression method.
+The symbols, ZIP_CM_STORE, ZIP_CM_DEFLATE and ZIP_CM_BZIP2 are used to
+select the compression method.
These constants are not imported by C<IO::Compress::Zip> by default.
@@ -1451,10 +1143,6 @@ Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must
be installed. A fatal error will be thrown if you attempt to create Bzip2
content when C<IO::Compress::Bzip2> is not available.
-Note that to create Lzma content, the module C<IO::Compress::Lzma> must
-be installed. A fatal error will be thrown if you attempt to create Lzma
-content when C<IO::Compress::Lzma> is not available.
-
The default method is ZIP_CM_DEFLATE.
=item C<< Stream => 0|1 >>
@@ -1469,15 +1157,11 @@ The default is 1.
=item C<< Zip64 => 0|1 >>
-Create a Zip64 zip file/buffer. This option is used if you want
-to store files larger than 4 Gig or store more than 64K files in a single
-zip archive..
-
-C<Zip64> will be automatically set, as needed, if working with the one-shot
-interface when the input is either a filename or a scalar reference.
+Create a Zip64 zip file/buffer. This option should only be used if you want
+to store files larger than 4 Gig.
If you intend to manipulate the Zip64 zip files created with this module
-using an external zip/unzip, make sure that it supports Zip64.
+using an external zip/unzip make sure that it supports Zip64.
In particular, if you are using Info-Zip you need to have zip version 3.x
or better to update a Zip64 archive and unzip version 6.x to read a zip64
@@ -1491,13 +1175,9 @@ This parameter controls the setting of a bit in the zip central header. It
is used to signal that the data stored in the zip file/buffer is probably
text.
-In one-shot mode this flag will be set to true if the Perl C<-T> operator thinks
-the file contains text.
-
The default is 0.
=item C<< ExtraFieldLocal => $data >>
-
=item C<< ExtraFieldCentral => $data >>
The C<ExtraFieldLocal> option is used to store additional metadata in the
@@ -1534,9 +1214,6 @@ Alternatively the list of subfields can by supplied as a scalar, thus
ExtraField => $rawdata
-In this case C<IO::Compress::Zip> will check that C<$rawdata> consists of
-zero or more conformant sub-fields.
-
The Extended Time field (ID "UT"), set using the C<exTime> option, and the
Unix2 extra field (ID "Ux), set using the C<exUnix2> option, are examples
of extra fields.
@@ -1549,8 +1226,7 @@ The maximum size of an extra field 65535 bytes.
If specified, this option will disable the creation of all extra fields
in the zip local and central headers. So the C<exTime>, C<exUnix2>,
-C<exUnixN>, C<ExtraFieldLocal> and C<ExtraFieldCentral> options will
-be ignored.
+C<ExtraFieldLocal> and C<ExtraFieldCentral> options will be ignored.
This parameter defaults to 0.
@@ -1577,32 +1253,6 @@ otherwise.
The default is 0.
-=item C<< Preset => number >>
-
-Used to choose the LZMA compression preset.
-
-Valid values are 0-9 and C<LZMA_PRESET_DEFAULT>.
-
-0 is the fastest compression with the lowest memory usage and the lowest
-compression.
-
-9 is the slowest compression with the highest memory usage but with the best
-compression.
-
-This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored
-otherwise.
-
-Defaults to C<LZMA_PRESET_DEFAULT> (6).
-
-=item C<< Extreme => 0|1 >>
-
-Makes LZMA compression a lot slower, but a small compression gain.
-
-This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored
-otherwise.
-
-Defaults to 0.
-
=item -Level
Defines the compression level used by zlib. The value should either be
@@ -1797,7 +1447,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -1833,7 +1483,7 @@ Usage is
Closes the current compressed data stream and starts a new one.
-OPTS consists of any of the options that are available when creating
+OPTS consists of any of the the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
@@ -1916,6 +1566,8 @@ constructor.
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
+
+
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
@@ -1924,7 +1576,7 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1953,7 +1605,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm
index 02609b940a4..c8cb95342a2 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm
@@ -7,7 +7,7 @@ require Exporter;
our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS);
-$VERSION = '2.064';
+$VERSION = '2.024';
@ISA = qw(Exporter);
@@ -38,9 +38,7 @@ $VERSION = '2.064';
ZIP_EXTRA_ID_ZIP64
ZIP_EXTRA_ID_EXT_TIMESTAMP
ZIP_EXTRA_ID_INFO_ZIP_UNIX2
- ZIP_EXTRA_ID_INFO_ZIP_UNIXN
- ZIP_EXTRA_ID_INFO_ZIP_Upath
- ZIP_EXTRA_ID_INFO_ZIP_Ucom
+ ZIP_EXTRA_ID_INFO_ZIP_UNIXn
ZIP_EXTRA_ID_JAVA_EXE
ZIP_OS_CODE_UNIX
@@ -51,12 +49,6 @@ $VERSION = '2.064';
%ZIP_CM_MIN_VERSIONS
ZIP64_MIN_VERSION
- ZIP_A_RONLY
- ZIP_A_HIDDEN
- ZIP_A_SYSTEM
- ZIP_A_LABEL
- ZIP_A_DIR
- ZIP_A_ARCHIVE
);
# Compression types supported
@@ -80,7 +72,6 @@ use constant ZIP_IFA_TEXT_MASK => 1;
# Signatures for each of the headers
use constant ZIP_LOCAL_HDR_SIG => 0x04034b50;
use constant ZIP_DATA_HDR_SIG => 0x08074b50;
-use constant packed_ZIP_DATA_HDR_SIG => pack "V", ZIP_DATA_HDR_SIG;
use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50;
use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50;
use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50;
@@ -95,27 +86,16 @@ use constant ZIP_OS_CODE_DEFAULT => 3;
use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1;
use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT";
use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux";
-use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXN => "ux";
-use constant ZIP_EXTRA_ID_INFO_ZIP_Upath => "up";
-use constant ZIP_EXTRA_ID_INFO_ZIP_Ucom => "uc";
+use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXn => "ux";
use constant ZIP_EXTRA_ID_JAVA_EXE => pack "v", 0xCAFE;
-# DOS Attributes
-use constant ZIP_A_RONLY => 0x01;
-use constant ZIP_A_HIDDEN => 0x02;
-use constant ZIP_A_SYSTEM => 0x04;
-use constant ZIP_A_LABEL => 0x08;
-use constant ZIP_A_DIR => 0x10;
-use constant ZIP_A_ARCHIVE => 0x20;
-
use constant ZIP64_MIN_VERSION => 45;
%ZIP_CM_MIN_VERSIONS = (
- ZIP_CM_STORE() => 20,
- ZIP_CM_DEFLATE() => 20,
- ZIP_CM_BZIP2() => 46,
- ZIP_CM_LZMA() => 63,
- ZIP_CM_PPMD() => 63,
+ ZIP_CM_STORE() => 20,
+ ZIP_CM_DEFLATE() => 20,
+ ZIP_CM_BZIP2() => 46,
+ ZIP_CM_LZMA() => 63,
);
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm
index 7dd1622dfb2..10fcf345f63 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm
@@ -9,7 +9,7 @@ require Exporter;
our ($VERSION, @ISA, @EXPORT);
-$VERSION = '2.064';
+$VERSION = '2.024';
@ISA = qw(Exporter);
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm
index ca92b5f9bd9..6812bb409dc 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm
@@ -1,6 +1,6 @@
package IO::Compress::Zlib::Extra;
-require 5.006 ;
+require 5.004 ;
use strict ;
use warnings;
@@ -8,9 +8,9 @@ use bytes;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
-$VERSION = '2.064';
+$VERSION = '2.024';
-use IO::Compress::Gzip::Constants 2.064 ;
+use IO::Compress::Gzip::Constants 2.024 ;
sub ExtraFieldError
{
@@ -98,38 +98,6 @@ sub parseRawExtra
return undef ;
}
-sub findID
-{
- my $id_want = shift ;
- my $data = shift;
-
- my $XLEN = length $data ;
-
- my $offset = 0 ;
- while ($offset < $XLEN) {
-
- return undef
- if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
-
- my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
- $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
-
- my $subLen = unpack("v", substr($data, $offset,
- GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
- $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
-
- return undef
- if $offset + $subLen > $XLEN ;
-
- return substr($data, $offset, $subLen)
- if $id eq $id_want ;
-
- $offset += $subLen ;
- }
-
- return undef ;
-}
-
sub mkSubField
{
@@ -174,6 +142,7 @@ sub parseExtraField
return parseRawExtra($dataRef, undef, 1, $gzipMode);
}
+ #my $data = $$dataRef;
my $data = $dataRef;
my $out = '' ;
@@ -194,7 +163,7 @@ sub parseExtraField
return ExtraFieldError("Not even number of elements")
unless @$data % 2 == 0;
- for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) {
+ for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) {
my $bad = validateExtraFieldPair([$data->[$ix],
$data->[$ix+1]],
$strict, $gzipMode) ;
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm
index 53b8ef1d583..98677e3c09f 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm
@@ -4,12 +4,12 @@ use strict;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status);
+use IO::Compress::Base::Common 2.024 qw(:Status);
-use Compress::Raw::Bzip2 2.064 ;
+use Compress::Raw::Bzip2 2.024 ;
our ($VERSION, @ISA);
-$VERSION = '2.064';
+$VERSION = '2.024';
sub mkUncompObject
{
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm
index 812f3f87d1b..27de6e0f36b 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm
@@ -4,131 +4,47 @@ use warnings;
use strict;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status);
-use IO::Compress::Zip::Constants ;
+use IO::Compress::Base::Common 2.024 qw(:Status);
our ($VERSION);
-$VERSION = '2.064';
+$VERSION = '2.024';
-use Compress::Raw::Zlib 2.064 ();
+use Compress::Raw::Zlib 2.024 ();
sub mkUncompObject
{
- my $streaming = shift;
- my $zip64 = shift;
-
my $crc32 = 1; #shift ;
my $adler32 = shift;
- bless { 'CompSize' => new U64 , # 0,
+ bless { 'CompSize' => 0,
'UnCompSize' => 0,
'wantCRC32' => $crc32,
'CRC32' => Compress::Raw::Zlib::crc32(''),
'wantADLER32'=> $adler32,
'ADLER32' => Compress::Raw::Zlib::adler32(''),
'ConsumesInput' => 1,
- 'Streaming' => $streaming,
- 'Zip64' => $zip64,
- 'DataHdrSize' => $zip64 ? 24 : 16,
- 'Pending' => '',
} ;
}
-
sub uncompr
{
my $self = shift;
- my $in = $_[0];
my $eof = $_[2];
- my $len = length $$in;
- my $remainder = '';
-
- if (defined $$in && $len) {
-
- if ($self->{Streaming}) {
-
- if (length $self->{Pending}) {
- $$in = $self->{Pending} . $$in ;
- $len = length $$in;
- $self->{Pending} = '';
- }
-
- my $ind = index($$in, "\x50\x4b\x07\x08");
-
- if ($ind < 0) {
- $len = length $$in;
- if ($len >= 3 && substr($$in, -3) eq "\x50\x4b\x07") {
- $ind = $len - 3 ;
- }
- elsif ($len >= 2 && substr($$in, -2) eq "\x50\x4b") {
- $ind = $len - 2 ;
- }
- elsif ($len >= 1 && substr($$in, -1) eq "\x50") {
- $ind = $len - 1 ;
- }
- }
-
- if ($ind >= 0) {
- $remainder = substr($$in, $ind) ;
- substr($$in, $ind) = '' ;
- }
- }
-
- if (length $remainder && length $remainder < $self->{DataHdrSize}) {
- $self->{Pending} = $remainder ;
- $remainder = '';
- }
- elsif (length $remainder >= $self->{DataHdrSize}) {
- my $crc = unpack "V", substr($remainder, 4);
- if ($crc == Compress::Raw::Zlib::crc32($$in, $self->{CRC32})) {
- my ($l1, $l2) ;
-
- if ($self->{Zip64}) {
- $l1 = U64::newUnpack_V64(substr($remainder, 8));
- $l2 = U64::newUnpack_V64(substr($remainder, 16));
- }
- else {
- $l1 = U64::newUnpack_V32(substr($remainder, 8));
- $l2 = U64::newUnpack_V32(substr($remainder, 12));
- }
-
- my $newLen = $self->{CompSize}->clone();
- $newLen->add(length $$in);
- if ($l1->equal($l2) && $l1->equal($newLen) ) {
- $eof = 1;
- }
- else {
- $$in .= substr($remainder, 0, 4) ;
- $remainder = substr($remainder, 4);
- #$self->{Pending} = substr($remainder, 4);
- #$remainder = '';
- $eof = 0;
- }
- }
- else {
- $$in .= substr($remainder, 0, 4) ;
- $remainder = substr($remainder, 4);
- #$self->{Pending} = substr($remainder, 4);
- #$remainder = '';
- $eof = 0;
- }
- }
-
- if (length $$in) {
- $self->{CompSize}->add(length $$in) ;
-
- $self->{CRC32} = Compress::Raw::Zlib::crc32($$in, $self->{CRC32})
- if $self->{wantCRC32};
-
- $self->{ADLER32} = Compress::Zlib::adler32($$in, $self->{ADLER32})
- if $self->{wantADLER32};
- }
-
- ${ $_[1] } .= $$in;
- $$in = $remainder;
+ if (defined ${ $_[0] } && length ${ $_[0] }) {
+ $self->{CompSize} += length ${ $_[0] } ;
+ $self->{UnCompSize} = $self->{CompSize} ;
+
+ $self->{CRC32} = Compress::Raw::Zlib::crc32($_[0], $self->{CRC32})
+ if $self->{wantCRC32};
+
+ $self->{ADLER32} = Compress::Zlib::adler32($_[0], $self->{ADLER32})
+ if $self->{wantADLER32};
+
+ ${ $_[1] } .= ${ $_[0] };
+ ${ $_[0] } = "";
}
return STATUS_ENDSTREAM if $eof;
@@ -147,6 +63,7 @@ sub reset
return STATUS_OK ;
}
+
#sub count
#{
# my $self = shift ;
@@ -156,13 +73,13 @@ sub reset
sub compressedBytes
{
my $self = shift ;
- return $self->{CompSize} ;
+ return $self->{UnCompSize} ;
}
sub uncompressedBytes
{
my $self = shift ;
- return $self->{CompSize} ;
+ return $self->{UnCompSize} ;
}
sub sync
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm
index 68beea145c9..aac1e413ffe 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm
@@ -2,13 +2,13 @@ package IO::Uncompress::Adapter::Inflate;
use strict;
use warnings;
-#use bytes;
+use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status);
-use Compress::Raw::Zlib 2.064 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
+use IO::Compress::Base::Common 2.024 qw(:Status);
+use Compress::Raw::Zlib 2.024 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
our ($VERSION);
-$VERSION = '2.064';
+$VERSION = '2.024';
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm
index cdf229a252a..68038f5d374 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm
@@ -6,22 +6,22 @@ use strict;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 ();
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
-use IO::Uncompress::Adapter::Inflate 2.064 ();
+use IO::Uncompress::Adapter::Inflate 2.024 ();
-use IO::Uncompress::Base 2.064 ;
-use IO::Uncompress::Gunzip 2.064 ;
-use IO::Uncompress::Inflate 2.064 ;
-use IO::Uncompress::RawInflate 2.064 ;
-use IO::Uncompress::Unzip 2.064 ;
+use IO::Uncompress::Base 2.024 ;
+use IO::Uncompress::Gunzip 2.024 ;
+use IO::Uncompress::Inflate 2.024 ;
+use IO::Uncompress::RawInflate 2.024 ;
+use IO::Uncompress::Unzip 2.024 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$AnyInflateError = '';
@ISA = qw( Exporter IO::Uncompress::Base );
@@ -36,20 +36,20 @@ Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$AnyInflateError);
+ my $obj = createSelfTiedObject($class, \$AnyInflateError);
$obj->_create(undef, 0, @_);
}
sub anyinflate
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$AnyInflateError);
+ my $obj = createSelfTiedObject(undef, \$AnyInflateError);
return $obj->_inf(@_) ;
}
sub getExtraParams
{
- use IO::Compress::Base::Common 2.064 qw(:Parse);
- return ( 'rawinflate' => [Parse_boolean, 0] ) ;
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ) ;
}
sub ckParams
@@ -58,8 +58,8 @@ sub ckParams
my $got = shift ;
# any always needs both crc32 and adler32
- $got->setValue('crc32' => 1);
- $got->setValue('adler32' => 1);
+ $got->value('CRC32' => 1);
+ $got->value('ADLER32' => 1);
return 1;
}
@@ -78,7 +78,7 @@ sub mkUncomp
my @possible = qw( Inflate Gunzip Unzip );
unshift @possible, 'RawInflate'
- if 1 || $got->getValue('rawinflate');
+ if 1 || $got->value('RawInflate');
my $magic = $self->ckMagic( @possible );
@@ -205,20 +205,19 @@ section.
use IO::Uncompress::AnyInflate qw(anyinflate $AnyInflateError) ;
- anyinflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ anyinflate $input => $output [,OPTS]
or die "anyinflate failed: $AnyInflateError\n";
The functional interface needs Perl5.005 or better.
-=head2 anyinflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 anyinflate $input => $output [, OPTS]
-C<anyinflate> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<anyinflate> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -226,25 +225,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -253,71 +252,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<anyinflate> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<anyinflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<anyinflate> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<anyinflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -379,8 +371,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -515,7 +507,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -570,7 +562,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -704,7 +696,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -742,7 +734,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -807,13 +799,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -859,7 +844,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -871,7 +856,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -960,13 +945,13 @@ Same as doing this
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+See L<IO::Uncompress::AnyInflate::FAQ|IO::Uncompress::AnyInflate::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -995,7 +980,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm
index e2b104dff43..5984921e25b 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm
@@ -4,16 +4,16 @@ use strict;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 ();
+use IO::Compress::Base::Common 2.024 qw(createSelfTiedObject);
-use IO::Uncompress::Base 2.064 ;
+use IO::Uncompress::Base 2.024 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$AnyUncompressError = '';
@ISA = qw( Exporter IO::Uncompress::Base );
@@ -27,41 +27,42 @@ Exporter::export_ok_tags('all');
BEGIN
{
- eval ' use IO::Uncompress::Adapter::Inflate 2.064 ;';
- eval ' use IO::Uncompress::Adapter::Bunzip2 2.064 ;';
- eval ' use IO::Uncompress::Adapter::LZO 2.064 ;';
- eval ' use IO::Uncompress::Adapter::Lzf 2.064 ;';
- eval ' use IO::Uncompress::Adapter::UnLzma 2.064 ;';
- eval ' use IO::Uncompress::Adapter::UnXz 2.064 ;';
-
- eval ' use IO::Uncompress::Bunzip2 2.064 ;';
- eval ' use IO::Uncompress::UnLzop 2.064 ;';
- eval ' use IO::Uncompress::Gunzip 2.064 ;';
- eval ' use IO::Uncompress::Inflate 2.064 ;';
- eval ' use IO::Uncompress::RawInflate 2.064 ;';
- eval ' use IO::Uncompress::Unzip 2.064 ;';
- eval ' use IO::Uncompress::UnLzf 2.064 ;';
- eval ' use IO::Uncompress::UnLzma 2.064 ;';
- eval ' use IO::Uncompress::UnXz 2.064 ;';
+ eval ' use IO::Uncompress::Adapter::Inflate 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::Bunzip2 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::LZO 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::Lzf 2.024 ;';
+ eval ' use IO::Uncompress::Adapter::UnLzma 2.020 ;';
+ eval ' use IO::Uncompress::Adapter::UnXz 2.020 ;';
+
+ eval ' use IO::Uncompress::Bunzip2 2.024 ;';
+ eval ' use IO::Uncompress::UnLzop 2.024 ;';
+ eval ' use IO::Uncompress::Gunzip 2.024 ;';
+ eval ' use IO::Uncompress::Inflate 2.024 ;';
+ eval ' use IO::Uncompress::RawInflate 2.024 ;';
+ eval ' use IO::Uncompress::Unzip 2.024 ;';
+ eval ' use IO::Uncompress::UnLzf 2.024 ;';
+ eval ' use IO::Uncompress::UnLzma 2.024 ;';
+ eval ' use IO::Uncompress::UnXz 2.024 ;';
}
sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$AnyUncompressError);
+ my $obj = createSelfTiedObject($class, \$AnyUncompressError);
$obj->_create(undef, 0, @_);
}
sub anyuncompress
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$AnyUncompressError);
+ my $obj = createSelfTiedObject(undef, \$AnyUncompressError);
return $obj->_inf(@_) ;
}
sub getExtraParams
-{
- return ( 'rawinflate' => [IO::Compress::Base::Common::Parse_boolean, 0] ,
- 'unlzma' => [IO::Compress::Base::Common::Parse_boolean, 0] ) ;
+{
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ return ( 'RawInflate' => [1, 1, Parse_boolean, 0] ,
+ 'UnLzma' => [1, 1, Parse_boolean, 0] ) ;
}
sub ckParams
@@ -70,8 +71,8 @@ sub ckParams
my $got = shift ;
# any always needs both crc32 and adler32
- $got->setValue('crc32' => 1);
- $got->setValue('adler32' => 1);
+ $got->value('CRC32' => 1);
+ $got->value('ADLER32' => 1);
return 1;
}
@@ -95,7 +96,7 @@ sub mkUncomp
my @possible = qw( Inflate Gunzip Unzip );
unshift @possible, 'RawInflate'
- if $got->getValue('rawinflate');
+ if $got->value('RawInflate');
$magic = $self->ckMagic( @possible );
@@ -107,7 +108,7 @@ sub mkUncomp
}
}
- if (defined $IO::Uncompress::UnLzma::VERSION && $got->getValue('unlzma'))
+ if (defined $IO::Uncompress::UnLzma::VERSION && $got->value('UnLzma'))
{
my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnLzma::mkUncompObject();
@@ -118,7 +119,7 @@ sub mkUncomp
my @possible = qw( UnLzma );
#unshift @possible, 'RawInflate'
- # if $got->getValue('rawinflate');
+ # if $got->value('RawInflate');
if ( *$self->{Info} = $self->ckMagic( @possible ))
{
@@ -313,20 +314,19 @@ section.
use IO::Uncompress::AnyUncompress qw(anyuncompress $AnyUncompressError) ;
- anyuncompress $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ anyuncompress $input => $output [,OPTS]
or die "anyuncompress failed: $AnyUncompressError\n";
The functional interface needs Perl5.005 or better.
-=head2 anyuncompress $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 anyuncompress $input => $output [, OPTS]
-C<anyuncompress> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<anyuncompress> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -334,25 +334,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -361,71 +361,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<anyuncompress> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<anyuncompress> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<anyuncompress> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<anyuncompress> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -487,8 +480,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -623,7 +616,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -678,7 +671,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -759,7 +752,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -797,7 +790,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -854,13 +847,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -906,7 +892,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -918,7 +904,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -1009,7 +995,7 @@ Same as doing this
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1025,7 +1011,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm
index 4d1b7802850..33f2ac23758 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm
@@ -3,27 +3,31 @@ package IO::Uncompress::Base ;
use strict ;
use warnings;
-#use bytes;
+use bytes;
our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS);
@ISA = qw(Exporter IO::File);
-$VERSION = '2.064';
+$VERSION = '2.024';
use constant G_EOF => 0 ;
use constant G_ERR => -1 ;
-use IO::Compress::Base::Common 2.064 ;
+use IO::Compress::Base::Common 2.024 ;
+#use Parse::Parameters ;
use IO::File ;
use Symbol;
-use Scalar::Util ();
-use List::Util ();
+use Scalar::Util qw(readonly);
+use List::Util qw(min);
use Carp ;
%EXPORT_TAGS = ( );
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
+#Exporter::export_ok_tags('all') ;
+
+
sub smartRead
{
@@ -33,16 +37,16 @@ sub smartRead
$$out = "" ;
my $offset = 0 ;
- my $status = 1;
if (defined *$self->{InputLength}) {
return 0
if *$self->{InputLengthRemaining} <= 0 ;
- $size = List::Util::min($size, *$self->{InputLengthRemaining});
+ $size = min($size, *$self->{InputLengthRemaining});
}
if ( length *$self->{Prime} ) {
+ #$$out = substr(*$self->{Prime}, 0, $size, '') ;
$$out = substr(*$self->{Prime}, 0, $size) ;
substr(*$self->{Prime}, 0, $size) = '' ;
if (length $$out == $size) {
@@ -65,12 +69,11 @@ sub smartRead
# because the filehandle may not support the offset parameter
# An example is Net::FTP
my $tmp = '';
- $status = *$self->{FH}->read($tmp, $get_size) ;
- substr($$out, $offset) = $tmp
- if defined $status && $status > 0 ;
+ *$self->{FH}->read($tmp, $get_size) &&
+ (substr($$out, $offset) = $tmp);
}
else
- { $status = *$self->{FH}->read($$out, $get_size) }
+ { *$self->{FH}->read($$out, $get_size) }
}
elsif (defined *$self->{InputEvent}) {
my $got = 1 ;
@@ -80,6 +83,7 @@ sub smartRead
}
if (length $$out > $size ) {
+ #*$self->{Prime} = substr($$out, $size, length($$out), '');
*$self->{Prime} = substr($$out, $size, length($$out));
substr($$out, $size, length($$out)) = '';
}
@@ -90,6 +94,7 @@ sub smartRead
no warnings 'uninitialized';
my $buf = *$self->{Buffer} ;
$$buf = '' unless defined $$buf ;
+ #$$out = '' unless defined $$out ;
substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size);
if (*$self->{ConsumeInput})
{ substr($$buf, 0, $get_size) = '' }
@@ -100,11 +105,6 @@ sub smartRead
*$self->{InputLengthRemaining} -= length($$out) #- $offset
if defined *$self->{InputLength};
- if (! defined $status) {
- $self->saveStatus($!) ;
- return STATUS_ERROR;
- }
-
$self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ;
return length $$out;
@@ -140,38 +140,19 @@ sub smartSeek
my $self = shift ;
my $offset = shift ;
my $truncate = shift;
- my $position = shift || SEEK_SET;
+ #print "smartSeek to $offset\n";
# TODO -- need to take prime into account
if (defined *$self->{FH})
- { *$self->{FH}->seek($offset, $position) }
+ { *$self->{FH}->seek($offset, SEEK_SET) }
else {
- if ($position == SEEK_END) {
- *$self->{BufferOffset} = length ${ *$self->{Buffer} } + $offset ;
- }
- elsif ($position == SEEK_CUR) {
- *$self->{BufferOffset} += $offset ;
- }
- else {
- *$self->{BufferOffset} = $offset ;
- }
-
+ *$self->{BufferOffset} = $offset ;
substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = ''
if $truncate;
return 1;
}
}
-sub smartTell
-{
- my $self = shift ;
-
- if (defined *$self->{FH})
- { return *$self->{FH}->tell() }
- else
- { return *$self->{BufferOffset} }
-}
-
sub smartWrite
{
my $self = shift ;
@@ -210,8 +191,7 @@ sub smartEof
#
# here, but this can cause trouble if
# the filehandle is itself a tied handle, but it uses sysread.
- # Then we get into mixing buffered & non-buffered IO,
- # which will cause trouble
+ # Then we get into mixing buffered & non-buffered IO, which will cause trouble
my $info = $self->getErrInfo();
@@ -219,7 +199,7 @@ sub smartEof
my $status = $self->smartRead(\$buffer, 1);
$self->pushBack($buffer) if length $buffer;
$self->setErrInfo($info);
-
+
return $status == 0 ;
}
elsif (defined *$self->{InputEvent})
@@ -256,6 +236,8 @@ sub saveStatus
{
my $self = shift ;
my $errno = shift() + 0 ;
+ #return $errno unless $errno || ! defined *$self->{ErrorNo};
+ #return $errno unless $errno ;
*$self->{ErrorNo} = $errno;
${ *$self->{Error} } = '' ;
@@ -269,9 +251,12 @@ sub saveErrorString
my $self = shift ;
my $retval = shift ;
+ #return $retval if ${ *$self->{Error} };
+
${ *$self->{Error} } = shift ;
- *$self->{ErrorNo} = @_ ? shift() + 0 : STATUS_ERROR ;
+ *$self->{ErrorNo} = shift() + 0 if @_ ;
+ #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ;
return $retval;
}
@@ -348,34 +333,34 @@ sub checkParams
my $got = shift || IO::Compress::Base::Parameters::new();
my $Valid = {
- 'blocksize' => [IO::Compress::Base::Common::Parse_unsigned, 16 * 1024],
- 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'strict' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'append' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'prime' => [IO::Compress::Base::Common::Parse_any, undef],
- 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'transparent' => [IO::Compress::Base::Common::Parse_any, 1],
- 'scan' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'inputlength' => [IO::Compress::Base::Common::Parse_unsigned, undef],
- 'binmodeout' => [IO::Compress::Base::Common::Parse_boolean, 0],
- #'decode' => [IO::Compress::Base::Common::Parse_any, undef],
-
- #'consumeinput' => [IO::Compress::Base::Common::Parse_boolean, 0],
-
+ 'BlockSize' => [1, 1, Parse_unsigned, 16 * 1024],
+ 'AutoClose' => [1, 1, Parse_boolean, 0],
+ 'Strict' => [1, 1, Parse_boolean, 0],
+ 'Append' => [1, 1, Parse_boolean, 0],
+ 'Prime' => [1, 1, Parse_any, undef],
+ 'MultiStream' => [1, 1, Parse_boolean, 0],
+ 'Transparent' => [1, 1, Parse_any, 1],
+ 'Scan' => [1, 1, Parse_boolean, 0],
+ 'InputLength' => [1, 1, Parse_unsigned, undef],
+ 'BinModeOut' => [1, 1, Parse_boolean, 0],
+ #'Encode' => [1, 1, Parse_any, undef],
+
+ #'ConsumeInput' => [1, 1, Parse_boolean, 0],
+
$self->getExtraParams(),
#'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
# ContinueAfterEof
} ;
- $Valid->{trailingdata} = [IO::Compress::Base::Common::Parse_writable_scalar, undef]
+ $Valid->{TrailingData} = [1, 1, Parse_writable_scalar, undef]
if *$self->{OneShot} ;
$got->parse($Valid, @_ )
- or $self->croakError("${class}: " . $got->getError()) ;
+ or $self->croakError("${class}: $got->{Error}") ;
$self->postCheckParams($got)
- or $self->croakError("${class}: " . $self->error()) ;
+ or $self->croakError("${class}: " . $self->error()) ;
return $got;
}
@@ -392,7 +377,7 @@ sub _create
my $inValue = shift ;
- *$obj->{OneShot} = 0 ;
+ *$obj->{OneShot} = 0 ;
if (! $got)
{
@@ -422,12 +407,12 @@ sub _create
# Need to rewind for Scan
*$obj->{FH}->seek(0, SEEK_SET)
- if $got->getValue('scan');
+ if $got->value('Scan');
}
else {
no warnings ;
my $mode = '<';
- $mode = '+<' if $got->getValue('scan');
+ $mode = '+<' if $got->value('Scan');
*$obj->{StdIO} = ($inValue eq '-');
*$obj->{FH} = new IO::File "$mode $inValue"
or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
@@ -440,34 +425,32 @@ sub _create
*$obj->{Buffer} = \$buff ;
}
-# if ($got->getValue('decode')) {
-# my $want_encoding = $got->getValue('decode');
-# *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding);
-# }
-# else {
-# *$obj->{Encoding} = undef;
-# }
+ if ($got->parsed('Encode')) {
+ my $want_encoding = $got->value('Encode');
+ *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding);
+ }
+
- *$obj->{InputLength} = $got->parsed('inputlength')
- ? $got->getValue('inputlength')
+ *$obj->{InputLength} = $got->parsed('InputLength')
+ ? $got->value('InputLength')
: undef ;
- *$obj->{InputLengthRemaining} = $got->getValue('inputlength');
+ *$obj->{InputLengthRemaining} = $got->value('InputLength');
*$obj->{BufferOffset} = 0 ;
- *$obj->{AutoClose} = $got->getValue('autoclose');
- *$obj->{Strict} = $got->getValue('strict');
- *$obj->{BlockSize} = $got->getValue('blocksize');
- *$obj->{Append} = $got->getValue('append');
- *$obj->{AppendOutput} = $append_mode || $got->getValue('append');
- *$obj->{ConsumeInput} = $got->getValue('consumeinput');
- *$obj->{Transparent} = $got->getValue('transparent');
- *$obj->{MultiStream} = $got->getValue('multistream');
+ *$obj->{AutoClose} = $got->value('AutoClose');
+ *$obj->{Strict} = $got->value('Strict');
+ *$obj->{BlockSize} = $got->value('BlockSize');
+ *$obj->{Append} = $got->value('Append');
+ *$obj->{AppendOutput} = $append_mode || $got->value('Append');
+ *$obj->{ConsumeInput} = $got->value('ConsumeInput');
+ *$obj->{Transparent} = $got->value('Transparent');
+ *$obj->{MultiStream} = $got->value('MultiStream');
# TODO - move these two into RawDeflate
- *$obj->{Scan} = $got->getValue('scan');
- *$obj->{ParseExtra} = $got->getValue('parseextra')
- || $got->getValue('strict') ;
+ *$obj->{Scan} = $got->value('Scan');
+ *$obj->{ParseExtra} = $got->value('ParseExtra')
+ || $got->value('Strict') ;
*$obj->{Type} = '';
- *$obj->{Prime} = $got->getValue('prime') || '' ;
+ *$obj->{Prime} = $got->value('Prime') || '' ;
*$obj->{Pending} = '';
*$obj->{Plain} = 0;
*$obj->{PlainBytesRead} = 0;
@@ -491,32 +474,14 @@ sub _create
return undef
unless defined $status;
- *$obj->{InNew} = 0;
- *$obj->{Closed} = 0;
-
- if ($status) {
- # Need to try uncompressing to catch the case
- # where the compressed file uncompresses to an
- # empty string - so eof is set immediately.
-
- my $out_buffer = '';
-
- $status = $obj->read(\$out_buffer);
-
- if ($status < 0) {
- *$obj->{ReadStatus} = [ $status, $obj->error(), $obj->errorNo() ];
- }
-
- $obj->ungetc($out_buffer)
- if length $out_buffer;
- }
- else {
+ if ( ! $status) {
return undef
unless *$obj->{Transparent};
$obj->clearError();
*$obj->{Type} = 'plain';
*$obj->{Plain} = 1;
+ #$status = $obj->mkIdentityUncomp($class, $got);
$obj->pushBack(*$obj->{HeaderPending}) ;
}
@@ -579,36 +544,13 @@ sub _inf
my $got = $obj->checkParams($name, undef, @_)
or return undef ;
- if ($got->parsed('trailingdata'))
+ if ($got->parsed('TrailingData'))
{
-# my $value = $got->valueRef('TrailingData');
-# warn "TD $value ";
-# #$value = $$value;
-## warn "TD $value $$value ";
-#
-# return retErr($obj, "Parameter 'TrailingData' not writable")
-# if readonly $$value ;
-#
-# if (ref $$value)
-# {
-# return retErr($obj,"Parameter 'TrailingData' not a scalar reference")
-# if ref $$value ne 'SCALAR' ;
-#
-# *$obj->{TrailingData} = $$value ;
-# }
-# else
-# {
-# return retErr($obj,"Parameter 'TrailingData' not a scalar")
-# if ref $value ne 'SCALAR' ;
-#
-# *$obj->{TrailingData} = $value ;
-# }
-
- *$obj->{TrailingData} = $got->getValue('trailingdata');
+ *$obj->{TrailingData} = $got->value('TrailingData');
}
- *$obj->{MultiStream} = $got->getValue('multistream');
- $got->setValue('multistream', 0);
+ *$obj->{MultiStream} = $got->value('MultiStream');
+ $got->value('MultiStream', 0);
$x->{Got} = $got ;
@@ -688,17 +630,17 @@ sub _singleTarget
if ($x->{outType} eq 'filename') {
my $mode = '>' ;
$mode = '>>'
- if $x->{Got}->getValue('append') ;
+ if $x->{Got}->value('Append') ;
$x->{fh} = new IO::File "$mode $output"
or return retErr($x, "cannot open file '$output': $!") ;
- binmode $x->{fh} if $x->{Got}->valueOrDefault('binmodeout');
+ binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
}
elsif ($x->{outType} eq 'handle') {
$x->{fh} = $output;
- binmode $x->{fh} if $x->{Got}->valueOrDefault('binmodeout');
- if ($x->{Got}->getValue('append')) {
+ binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
+ if ($x->{Got}->value('Append')) {
seek($x->{fh}, 0, SEEK_END)
or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
}
@@ -708,7 +650,7 @@ sub _singleTarget
elsif ($x->{outType} eq 'buffer' )
{
$$output = ''
- unless $x->{Got}->getValue('append');
+ unless $x->{Got}->value('Append');
$x->{buff} = $output ;
}
@@ -728,7 +670,7 @@ sub _singleTarget
if ( ($x->{outType} eq 'filename' && $output ne '-') ||
- ($x->{outType} eq 'handle' && $x->{Got}->getValue('autoclose'))) {
+ ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
$x->{fh}->close()
or return retErr($x, $!);
delete $x->{fh};
@@ -744,7 +686,7 @@ sub _rd2
my $input = shift;
my $output = shift;
- my $z = IO::Compress::Base::Common::createSelfTiedObject($x->{Class}, *$self->{Error});
+ my $z = createSelfTiedObject($x->{Class}, *$self->{Error});
$z->_create($x->{Got}, 1, $input, @_)
or return undef ;
@@ -756,7 +698,7 @@ sub _rd2
while (($status = $z->read($x->{buff})) > 0) {
if ($fh) {
- syswrite $fh, ${ $x->{buff} }
+ print $fh ${ $x->{buff} }
or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
${ $x->{buff} } = '' ;
}
@@ -775,6 +717,7 @@ sub _rd2
}
last if $status < 0 || $z->smartEof();
+ #last if $status < 0 ;
last
unless *$self->{MultiStream};
@@ -828,13 +771,13 @@ sub readBlock
*$self->{CompressedInputLengthDone} = 1;
return STATUS_OK ;
}
- $size = List::Util::min($size, *$self->{CompressedInputLengthRemaining} );
+ $size = min($size, *$self->{CompressedInputLengthRemaining} );
*$self->{CompressedInputLengthRemaining} -= $size ;
}
my $status = $self->smartRead($buff, $size) ;
- return $self->saveErrorString(STATUS_ERROR, "Error Reading Data: $!", $!)
- if $status == STATUS_ERROR ;
+ return $self->saveErrorString(STATUS_ERROR, "Error Reading Data")
+ if $status < 0 ;
if ($status == 0 ) {
*$self->{Closed} = 1 ;
@@ -860,6 +803,7 @@ sub _raw_read
my $self = shift ;
return G_EOF if *$self->{Closed} ;
+ #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
return G_EOF if *$self->{EndStream} ;
my $buffer = shift ;
@@ -870,7 +814,7 @@ sub _raw_read
my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
- if $len == STATUS_ERROR ;
+ if $len < 0 ;
if ($len == 0 ) {
*$self->{EndStream} = 1 ;
@@ -899,7 +843,6 @@ sub _raw_read
my $temp_buf = '';
my $outSize = 0;
my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
-
return G_ERR
if $status == STATUS_ERROR ;
@@ -928,19 +871,18 @@ sub _raw_read
*$self->{TotalInflatedBytesRead} += $buf_len ;
*$self->{UnCompSize}->add($buf_len) ;
- $self->filterUncompressed($buffer, $before_len);
+ $self->filterUncompressed($buffer);
-# if (*$self->{Encoding}) {
-# use Encode ;
-# *$self->{PendingDecode} .= substr($$buffer, $before_len) ;
-# my $got = *$self->{Encoding}->decode(*$self->{PendingDecode}, Encode::FB_QUIET) ;
-# substr($$buffer, $before_len) = $got;
-# }
+ if (*$self->{Encoding}) {
+ $$buffer = *$self->{Encoding}->decode($$buffer);
+ }
}
if ($status == STATUS_ENDSTREAM) {
*$self->{EndStream} = 1 ;
+#$self->pushBack($temp_buf) ;
+#$temp_buf = '';
my $trailer;
my $trailer_size = *$self->{Info}{TrailerLength} ;
@@ -961,7 +903,7 @@ sub _raw_read
$self->pushBack($trailer) ;
}
- # TODO - if want file pointer, do it here
+ # TODO - if want to file file pointer, do it here
if (! $self->smartEof()) {
*$self->{NewStream} = 1 ;
@@ -1030,16 +972,15 @@ sub gotoNextStream
*$self->{NewStream} = 0 ;
*$self->{EndStream} = 0 ;
- *$self->{CompressedInputLengthDone} = undef ;
- *$self->{CompressedInputLength} = undef ;
$self->reset();
*$self->{UnCompSize}->reset();
*$self->{CompSize}->reset();
my $magic = $self->ckMagic();
+ #*$self->{EndStream} = 0 ;
if ( ! defined $magic) {
- if (! *$self->{Transparent} || $self->eof())
+ if (! *$self->{Transparent} )
{
*$self->{EndStream} = 1 ;
return 0;
@@ -1072,13 +1013,6 @@ sub streamCount
return scalar @{ *$self->{InfoList} } ;
}
-#sub read
-#{
-# my $status = myRead(@_);
-# return undef if $status < 0;
-# return $status;
-#}
-
sub read
{
# return codes
@@ -1088,20 +1022,13 @@ sub read
my $self = shift ;
- if (defined *$self->{ReadStatus} ) {
- my $status = *$self->{ReadStatus}[0];
- $self->saveErrorString( @{ *$self->{ReadStatus} } );
- delete *$self->{ReadStatus} ;
- return $status ;
- }
-
return G_EOF if *$self->{Closed} ;
my $buffer ;
if (ref $_[0] ) {
$self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
- if Scalar::Util::readonly(${ $_[0] });
+ if readonly(${ $_[0] });
$self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
unless ref $_[0] eq 'SCALAR' ;
@@ -1109,7 +1036,7 @@ sub read
}
else {
$self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
- if Scalar::Util::readonly($_[0]);
+ if readonly($_[0]);
$buffer = \$_[0] ;
}
@@ -1130,9 +1057,6 @@ sub read
}
}
}
- elsif (! defined $$buffer) {
- $$buffer = '' ;
- }
return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
@@ -1189,6 +1113,7 @@ sub read
*$self->{Pending} = $out_buffer;
$out_buffer = \*$self->{Pending} ;
+ #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
substr($$out_buffer, 0, $length) = '' ;
@@ -1198,78 +1123,70 @@ sub read
sub _getline
{
my $self = shift ;
- my $status = 0 ;
# Slurp Mode
if ( ! defined $/ ) {
my $data ;
- 1 while ($status = $self->read($data)) > 0 ;
- return ($status, \$data);
+ 1 while $self->read($data) > 0 ;
+ return \$data ;
}
# Record Mode
if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) {
my $reclen = ${$/} ;
my $data ;
- $status = $self->read($data, $reclen) ;
- return ($status, \$data);
+ $self->read($data, $reclen) ;
+ return \$data ;
}
# Paragraph Mode
if ( ! length $/ ) {
my $paragraph ;
- while (($status = $self->read($paragraph)) > 0 ) {
+ while ($self->read($paragraph) > 0 ) {
if ($paragraph =~ s/^(.*?\n\n+)//s) {
*$self->{Pending} = $paragraph ;
my $par = $1 ;
- return (1, \$par);
+ return \$par ;
}
}
- return ($status, \$paragraph);
+ return \$paragraph;
}
# $/ isn't empty, or a reference, so it's Line Mode.
{
my $line ;
+ my $offset;
my $p = \*$self->{Pending} ;
- while (($status = $self->read($line)) > 0 ) {
+
+ if (length(*$self->{Pending}) &&
+ ($offset = index(*$self->{Pending}, $/)) >=0) {
+ my $l = substr(*$self->{Pending}, 0, $offset + length $/ );
+ substr(*$self->{Pending}, 0, $offset + length $/) = '';
+ return \$l;
+ }
+
+ while ($self->read($line) > 0 ) {
my $offset = index($line, $/);
if ($offset >= 0) {
my $l = substr($line, 0, $offset + length $/ );
substr($line, 0, $offset + length $/) = '';
$$p = $line;
- return (1, \$l);
+ return \$l;
}
}
- return ($status, \$line);
+ return \$line;
}
}
sub getline
{
my $self = shift;
-
- if (defined *$self->{ReadStatus} ) {
- $self->saveErrorString( @{ *$self->{ReadStatus} } );
- delete *$self->{ReadStatus} ;
- return undef;
- }
-
- return undef
- if *$self->{Closed} || (!length *$self->{Pending} && *$self->{EndStream}) ;
-
my $current_append = *$self->{AppendOutput} ;
*$self->{AppendOutput} = 1;
-
- my ($status, $lineref) = $self->_getline();
+ my $lineref = $self->_getline();
+ $. = ++ *$self->{LineNo} if defined $$lineref ;
*$self->{AppendOutput} = $current_append;
-
- return undef
- if $status < 0 || length $$lineref == 0 ;
-
- $. = ++ *$self->{LineNo} ;
-
return $$lineref ;
}
@@ -1363,6 +1280,7 @@ sub close
if (defined *$self->{FH}) {
if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
+ #if ( *$self->{AutoClose}) {
local $.;
$! = 0 ;
$status = *$self->{FH}->close();
@@ -1430,7 +1348,7 @@ sub seek
my $offset = $target - $here ;
my $got;
- while (($got = $self->read(my $buffer, List::Util::min($offset, *$self->{BlockSize})) ) > 0)
+ while (($got = $self->read(my $buffer, min($offset, *$self->{BlockSize})) ) > 0)
{
$offset -= $got;
last if $offset == 0 ;
@@ -1493,6 +1411,7 @@ sub input_line_number
sub _notAvailable
{
my $name = shift ;
+ #return sub { croak "$name Not Available" ; } ;
return sub { croak "$name Not Available: File opened only for intput" ; } ;
}
@@ -1526,13 +1445,13 @@ IO::Uncompress::Base - Base Class for IO::Uncompress modules
=head1 DESCRIPTION
This module is not intended for direct use in application code. Its sole
-purpose is to be sub-classed by IO::Uncompress modules.
+purpose if to to be sub-classed by IO::Unompress modules.
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1548,7 +1467,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm
index aad835f32f3..b3988c41851 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm
@@ -4,15 +4,15 @@ use strict ;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status );
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
-use IO::Uncompress::Base 2.064 ;
-use IO::Uncompress::Adapter::Bunzip2 2.064 ;
+use IO::Uncompress::Base 2.024 ;
+use IO::Uncompress::Adapter::Bunzip2 2.024 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error);
-$VERSION = '2.064';
+$VERSION = '2.024';
$Bunzip2Error = '';
@ISA = qw( Exporter IO::Uncompress::Base );
@@ -25,22 +25,26 @@ push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bunzip2Error);
+ my $obj = createSelfTiedObject($class, \$Bunzip2Error);
$obj->_create(undef, 0, @_);
}
sub bunzip2
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bunzip2Error);
+ my $obj = createSelfTiedObject(undef, \$Bunzip2Error);
return $obj->_inf(@_);
}
sub getExtraParams
{
+ my $self = shift ;
+
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+
return (
- 'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0],
- 'small' => [IO::Compress::Base::Common::Parse_boolean, 0],
+ 'Verbosity' => [1, 1, Parse_boolean, 0],
+ 'Small' => [1, 1, Parse_boolean, 0],
);
}
@@ -64,8 +68,8 @@ sub mkUncomp
*$self->{Info} = $self->readHeader($magic)
or return undef ;
- my $Small = $got->getValue('small');
- my $Verbosity = $got->getValue('verbosity');
+ my $Small = $got->value('Small');
+ my $Verbosity = $got->value('Verbosity');
my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(
$Small, $Verbosity);
@@ -201,20 +205,19 @@ section.
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
- bunzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ bunzip2 $input => $output [,OPTS]
or die "bunzip2 failed: $Bunzip2Error\n";
The functional interface needs Perl5.005 or better.
-=head2 bunzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 bunzip2 $input => $output [, OPTS]
-C<bunzip2> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<bunzip2> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -222,25 +225,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -249,71 +252,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<bunzip2> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<bunzip2> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<bunzip2> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<bunzip2> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -345,48 +341,7 @@ Defaults to 0.
=item C<< Append => 0|1 >>
-The behaviour of this option is dependent on the type of output data
-stream.
-
-=over 5
-
-=item * A Buffer
-
-If C<Append> is enabled, all uncompressed data will be append to the end of
-the output buffer. Otherwise the output buffer will be cleared before any
-uncompressed data is written to it.
-
-=item * A Filename
-
-If C<Append> is enabled, the file will be opened in append mode. Otherwise
-the contents of the file, if any, will be truncated before any uncompressed
-data is written to it.
-
-=item * A Filehandle
-
-If C<Append> is enabled, the filehandle will be positioned to the end of
-the file via a call to C<seek> before any uncompressed data is
-written to it. Otherwise the file pointer will not be moved.
-
-=back
-
-When C<Append> is specified, and set to true, it will I<append> all uncompressed
-data to the output data stream.
-
-So when the output is a filehandle it will carry out a seek to the eof
-before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
-
-Conversely when C<Append> is not specified, or it is present and is set to
-false, it will operate as follows.
-
-When the output is a filename, it will truncate the contents of the file
-before writing any uncompressed data. If the output is a filehandle
-its position will not be changed. If the output is a buffer, it will be
-wiped before any uncompressed data is output.
-
-Defaults to 0.
+TODO
=item C<< MultiStream => 0|1 >>
@@ -423,7 +378,7 @@ C<InputLength> option.
=head2 Examples
To read the contents of the file C<file1.txt.bz2> and write the
-uncompressed data to the file C<file1.txt>.
+compressed data to the file C<file1.txt>.
use strict ;
use warnings ;
@@ -511,7 +466,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -566,7 +521,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -629,7 +584,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -667,7 +622,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -724,13 +679,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -776,7 +724,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -788,7 +736,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -877,13 +825,13 @@ Same as doing this
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+See L<IO::Uncompress::Bunzip2::FAQ|IO::Uncompress::Bunzip2::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
-L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
+L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -903,7 +851,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2008 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm
index b8012d0ee0d..f3e4e6561f0 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm
@@ -1,7 +1,7 @@
package IO::Uncompress::Gunzip ;
-require 5.006 ;
+require 5.004 ;
# for RFC1952
@@ -9,12 +9,12 @@ use strict ;
use warnings;
use bytes;
-use IO::Uncompress::RawInflate 2.064 ;
+use IO::Uncompress::RawInflate 2.024 ;
-use Compress::Raw::Zlib 2.064 () ;
-use IO::Compress::Base::Common 2.064 qw(:Status );
-use IO::Compress::Gzip::Constants 2.064 ;
-use IO::Compress::Zlib::Extra 2.064 ;
+use Compress::Raw::Zlib 2.024 qw( crc32 ) ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::Gzip::Constants 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
require Exporter ;
@@ -28,26 +28,27 @@ Exporter::export_ok_tags('all');
$GunzipError = '';
-$VERSION = '2.064';
+$VERSION = '2.024';
sub new
{
my $class = shift ;
$GunzipError = '';
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$GunzipError);
+ my $obj = createSelfTiedObject($class, \$GunzipError);
$obj->_create(undef, 0, @_);
}
sub gunzip
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$GunzipError);
+ my $obj = createSelfTiedObject(undef, \$GunzipError);
return $obj->_inf(@_) ;
}
sub getExtraParams
{
- return ( 'parseextra' => [IO::Compress::Base::Common::Parse_boolean, 0] ) ;
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+ return ( 'ParseExtra' => [1, 1, Parse_boolean, 0] ) ;
}
sub ckParams
@@ -56,7 +57,7 @@ sub ckParams
my $got = shift ;
# gunzip always needs crc32
- $got->setValue('crc32' => 1);
+ $got->value('CRC32' => 1);
return 1;
}
@@ -221,7 +222,7 @@ sub _readGzipHeader($)
or return $self->TruncatedHeader("FHCRC");
$HeaderCRC = unpack("v", $buffer) ;
- my $crc16 = Compress::Raw::Zlib::crc32($keep) & 0xFF ;
+ my $crc16 = crc32($keep) & 0xFF ;
return $self->HeaderError("CRC16 mismatch.")
if *$self->{Strict} && $crc16 != $HeaderCRC;
@@ -340,20 +341,19 @@ section.
use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;
- gunzip $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ gunzip $input => $output [,OPTS]
or die "gunzip failed: $GunzipError\n";
The functional interface needs Perl5.005 or better.
-=head2 gunzip $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 gunzip $input => $output [, OPTS]
-C<gunzip> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<gunzip> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -361,25 +361,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -388,71 +388,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<gunzip> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<gunzip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<gunzip> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<gunzip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -514,8 +507,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -650,7 +643,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -705,7 +698,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -811,7 +804,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -849,7 +842,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -930,13 +923,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -982,7 +968,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -994,7 +980,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -1083,13 +1069,13 @@ Same as doing this
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+See L<IO::Uncompress::Gunzip::FAQ|IO::Uncompress::Gunzip::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1118,7 +1104,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm
index a5df2eacb95..956f62e0835 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm
@@ -5,15 +5,15 @@ use strict ;
use warnings;
use bytes;
-use IO::Compress::Base::Common 2.064 qw(:Status );
-use IO::Compress::Zlib::Constants 2.064 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Compress::Zlib::Constants 2.024 ;
-use IO::Uncompress::RawInflate 2.064 ;
+use IO::Uncompress::RawInflate 2.024 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$InflateError = '';
@ISA = qw( Exporter IO::Uncompress::RawInflate );
@@ -26,14 +26,14 @@ Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$InflateError);
+ my $obj = createSelfTiedObject($class, \$InflateError);
$obj->_create(undef, 0, @_);
}
sub inflate
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$InflateError);
+ my $obj = createSelfTiedObject(undef, \$InflateError);
return $obj->_inf(@_);
}
@@ -48,7 +48,7 @@ sub ckParams
my $got = shift ;
# gunzip always needs adler32
- $got->setValue('adler32' => 1);
+ $got->value('ADLER32' => 1);
return 1;
}
@@ -262,20 +262,19 @@ section.
use IO::Uncompress::Inflate qw(inflate $InflateError) ;
- inflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ inflate $input => $output [,OPTS]
or die "inflate failed: $InflateError\n";
The functional interface needs Perl5.005 or better.
-=head2 inflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 inflate $input => $output [, OPTS]
-C<inflate> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<inflate> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -283,25 +282,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -310,71 +309,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<inflate> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<inflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<inflate> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<inflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -436,8 +428,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -572,7 +564,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -627,7 +619,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -699,7 +691,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -737,7 +729,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -802,13 +794,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -854,7 +839,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -866,7 +851,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -955,13 +940,13 @@ Same as doing this
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+See L<IO::Uncompress::Inflate::FAQ|IO::Uncompress::Inflate::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -990,7 +975,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm
index b0259f30430..f017fa0f599 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm
@@ -3,18 +3,18 @@ package IO::Uncompress::RawInflate ;
use strict ;
use warnings;
-#use bytes;
+use bytes;
-use Compress::Raw::Zlib 2.064 ;
-use IO::Compress::Base::Common 2.064 qw(:Status );
+use Compress::Raw::Zlib 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
-use IO::Uncompress::Base 2.064 ;
-use IO::Uncompress::Adapter::Inflate 2.064 ;
+use IO::Uncompress::Base 2.024 ;
+use IO::Uncompress::Adapter::Inflate 2.024 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError);
-$VERSION = '2.064';
+$VERSION = '2.024';
$RawInflateError = '';
@ISA = qw( Exporter IO::Uncompress::Base );
@@ -45,13 +45,13 @@ Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$RawInflateError);
+ my $obj = createSelfTiedObject($class, \$RawInflateError);
$obj->_create(undef, 0, @_);
}
sub rawinflate
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$RawInflateError);
+ my $obj = createSelfTiedObject(undef, \$RawInflateError);
return $obj->_inf(@_);
}
@@ -74,9 +74,9 @@ sub mkUncomp
my $got = shift ;
my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Inflate::mkUncompObject(
- $got->getValue('crc32'),
- $got->getValue('adler32'),
- $got->getValue('scan'),
+ $got->value('CRC32'),
+ $got->value('ADLER32'),
+ $got->value('Scan'),
);
return $self->saveErrorString(undef, $errstr, $errno)
@@ -332,8 +332,8 @@ sub createDeflate
my ($def, $status) = *$self->{Uncomp}->createDeflateStream(
-AppendOutput => 1,
-WindowBits => - MAX_WBITS,
- -CRC32 => *$self->{Params}->getValue('crc32'),
- -ADLER32 => *$self->{Params}->getValue('adler32'),
+ -CRC32 => *$self->{Params}->value('CRC32'),
+ -ADLER32 => *$self->{Params}->value('ADLER32'),
);
return wantarray ? ($status, $def) : $def ;
@@ -410,20 +410,19 @@ section.
use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError) ;
- rawinflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ rawinflate $input => $output [,OPTS]
or die "rawinflate failed: $RawInflateError\n";
The functional interface needs Perl5.005 or better.
-=head2 rawinflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 rawinflate $input => $output [, OPTS]
-C<rawinflate> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<rawinflate> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -431,25 +430,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -458,71 +457,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<rawinflate> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<rawinflate> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<rawinflate> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<rawinflate> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -584,8 +576,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -717,7 +709,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -772,7 +764,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -827,7 +819,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -865,7 +857,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -930,13 +922,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -982,7 +967,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -994,7 +979,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -1083,13 +1068,13 @@ Same as doing this
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
+See L<IO::Uncompress::RawInflate::FAQ|IO::Uncompress::RawInflate::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1118,7 +1103,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm
index 3b36f839a05..e7d6849f66b 100644
--- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm
+++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm
@@ -1,29 +1,28 @@
package IO::Uncompress::Unzip;
-require 5.006 ;
+require 5.004 ;
# for RFC1952
use strict ;
use warnings;
-#use bytes;
+use bytes;
-use IO::File;
-use IO::Uncompress::RawInflate 2.064 ;
-use IO::Compress::Base::Common 2.064 qw(:Status );
-use IO::Uncompress::Adapter::Inflate 2.064 ;
-use IO::Uncompress::Adapter::Identity 2.064 ;
-use IO::Compress::Zlib::Extra 2.064 ;
-use IO::Compress::Zip::Constants 2.064 ;
+use IO::Uncompress::RawInflate 2.024 ;
+use IO::Compress::Base::Common 2.024 qw(:Status createSelfTiedObject);
+use IO::Uncompress::Adapter::Inflate 2.024 ;
+use IO::Uncompress::Adapter::Identity 2.024 ;
+use IO::Compress::Zlib::Extra 2.024 ;
+use IO::Compress::Zip::Constants 2.024 ;
-use Compress::Raw::Zlib 2.064 () ;
+use Compress::Raw::Zlib 2.024 qw(crc32) ;
BEGIN
{
- eval{ require IO::Uncompress::Adapter::Bunzip2 ;
+ eval { require IO::Uncompress::Adapter::Bunzip2 ;
import IO::Uncompress::Adapter::Bunzip2 } ;
- eval{ require IO::Uncompress::Adapter::UnLzma ;
- import IO::Uncompress::Adapter::UnLzma } ;
+# eval { require IO::Uncompress::Adapter::UnLzma ;
+# import IO::Uncompress::Adapter::UnLzma } ;
}
@@ -31,7 +30,7 @@ require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup);
-$VERSION = '2.064';
+$VERSION = '2.024';
$UnzipError = '';
@ISA = qw(Exporter IO::Uncompress::RawInflate);
@@ -52,26 +51,27 @@ Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
- my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$UnzipError);
+ my $obj = createSelfTiedObject($class, \$UnzipError);
$obj->_create(undef, 0, @_);
}
sub unzip
{
- my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$UnzipError);
+ my $obj = createSelfTiedObject(undef, \$UnzipError);
return $obj->_inf(@_) ;
}
sub getExtraParams
{
-
+ use IO::Compress::Base::Common 2.024 qw(:Parse);
+
+
return (
# # Zip header fields
- 'name' => [IO::Compress::Base::Common::Parse_any, undef],
+ 'Name' => [1, 1, Parse_any, undef],
- 'stream' => [IO::Compress::Base::Common::Parse_boolean, 0],
-
- # TODO - This means reading the central directory to get
+# 'Stream' => [1, 1, Parse_boolean, 1],
+ # This means reading the central directory to get
# 1. the local header offsets
# 2. The compressed data length
);
@@ -83,9 +83,9 @@ sub ckParams
my $got = shift ;
# unzip always needs crc32
- $got->setValue('crc32' => 1);
+ $got->value('CRC32' => 1);
- *$self->{UnzipData}{Name} = $got->getValue('name');
+ *$self->{UnzipData}{Name} = $got->value('Name');
return 1;
}
@@ -415,7 +415,7 @@ sub skipCentralDirectory64Rec
my $keep = $magic . $buffer ;
my ($sizeLo, $sizeHi) = unpack ("V V", $buffer);
- my $size = $sizeHi * U64::MAX32 + $sizeLo;
+ my $size = $sizeHi * 0xFFFFFFFF + $sizeLo;
$self->fastForward($size)
or return $self->TrailerError("Minimum header size is " .
@@ -473,8 +473,8 @@ sub skipEndCentralDirectory
#my $cntrlDirDiskNo = unpack ("v", substr($buffer, 6-4, 2));
#my $entriesInThisCD = unpack ("v", substr($buffer, 8-4, 2));
#my $entriesInCD = unpack ("v", substr($buffer, 10-4, 2));
- #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 4));
- #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 4));
+ #my $sizeOfCD = unpack ("V", substr($buffer, 12-4, 2));
+ #my $offsetToCD = unpack ("V", substr($buffer, 16-4, 2));
my $comment_length = unpack ("v", substr($buffer, 20-4, 2));
@@ -549,6 +549,9 @@ sub _readZipHeader($)
my @EXTRA = ();
my $streamingMode = ($gpFlag & ZIP_GP_FLAG_STREAMING_MASK) ? 1 : 0 ;
+ return $self->HeaderError("Streamed Stored content not supported")
+ if $streamingMode && $compressedMethod == 0 ;
+
return $self->HeaderError("Encrypted content not supported")
if $gpFlag & (ZIP_GP_FLAG_ENCRYPTED_MASK|ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK);
@@ -598,14 +601,14 @@ sub _readZipHeader($)
if (! $streamingMode) {
my $offset = 0 ;
- if (U64::full32 $uncompressedLength->get32bit() ) {
+ if ($uncompressedLength->get32bit() == 0xFFFFFFFF ) {
$uncompressedLength
= U64::newUnpack_V64 substr($buff, 0, 8);
$offset += 8 ;
}
- if (U64::full32 $compressedLength->get32bit() ) {
+ if ($compressedLength->get32bit() == 0xFFFFFFFF) {
$compressedLength
= U64::newUnpack_V64 substr($buff, $offset, 8);
@@ -627,7 +630,7 @@ sub _readZipHeader($)
*$self->{CompressedInputLength} = $compressedLength->get64bit();
}
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(undef);
+ *$self->{ZipData}{CRC32} = crc32(undef);
*$self->{ZipData}{Method} = $compressedMethod;
if ($compressedMethod == ZIP_CM_DEFLATE)
{
@@ -647,41 +650,41 @@ sub _readZipHeader($)
*$self->{Uncomp} = $obj;
}
- elsif ($compressedMethod == ZIP_CM_LZMA)
- {
- return $self->HeaderError("Unsupported Compression format $compressedMethod")
- if ! defined $IO::Uncompress::Adapter::UnLzma::VERSION ;
-
- *$self->{Type} = 'zip-lzma';
- my $LzmaHeader;
- $self->smartReadExact(\$LzmaHeader, 4)
- or return $self->saveErrorString(undef, "Truncated file");
- my ($verHi, $verLo) = unpack ("CC", substr($LzmaHeader, 0, 2));
- my $LzmaPropertiesSize = unpack ("v", substr($LzmaHeader, 2, 2));
-
-
- my $LzmaPropertyData;
- $self->smartReadExact(\$LzmaPropertyData, $LzmaPropertiesSize)
- or return $self->saveErrorString(undef, "Truncated file");
-
- if (! $streamingMode) {
- *$self->{ZipData}{CompressedLen}->subtract(4 + $LzmaPropertiesSize) ;
- *$self->{CompressedInputLengthRemaining} =
- *$self->{CompressedInputLength} = *$self->{ZipData}{CompressedLen}->get64bit();
- }
-
- my $obj =
- IO::Uncompress::Adapter::UnLzma::mkUncompZipObject($LzmaPropertyData);
-
- *$self->{Uncomp} = $obj;
- }
+# elsif ($compressedMethod == ZIP_CM_LZMA)
+# {
+# return $self->HeaderError("Unsupported Compression format $compressedMethod")
+# if ! defined $IO::Uncompress::Adapter::UnLzma::VERSION ;
+#
+# *$self->{Type} = 'zip-lzma';
+# my $LzmaHeader;
+# $self->smartReadExact(\$LzmaHeader, 4)
+# or return $self->saveErrorString(undef, "Truncated file");
+# my ($verHi, $verLo) = unpack ("CC", substr($LzmaHeader, 0, 2));
+# my $LzmaPropertiesSize = unpack ("v", substr($LzmaHeader, 2, 2));
+#
+#
+# my $LzmaPropertyData;
+# $self->smartReadExact(\$LzmaPropertyData, $LzmaPropertiesSize)
+# or return $self->saveErrorString(undef, "Truncated file");
+# #my $LzmaInfo = unpack ("C", substr($LzmaPropertyData, 0, 1));
+# #my $LzmaDictSize = unpack ("V", substr($LzmaPropertyData, 1, 4));
+#
+# # Create an LZMA_Alone header
+# $self->pushBack($LzmaPropertyData .
+# $uncompressedLength->getPacked_V64());
+#
+# my $obj =
+# IO::Uncompress::Adapter::UnLzma::mkUncompObject();
+#
+# *$self->{Uncomp} = $obj;
+# }
elsif ($compressedMethod == ZIP_CM_STORE)
{
+ # TODO -- add support for reading uncompressed
+
*$self->{Type} = 'zip-stored';
- my $obj =
- IO::Uncompress::Adapter::Identity::mkUncompObject($streamingMode,
- $zip64);
+ my $obj = IO::Uncompress::Adapter::Identity::mkUncompObject();
*$self->{Uncomp} = $obj;
}
@@ -743,7 +746,7 @@ sub filterUncompressed
*$self->{ZipData}{CRC32} = *$self->{Uncomp}->crc32() ;
}
else {
- *$self->{ZipData}{CRC32} = Compress::Raw::Zlib::crc32(${$_[0]}, *$self->{ZipData}{CRC32}, $_[1]);
+ *$self->{ZipData}{CRC32} = crc32(${$_[0]}, *$self->{ZipData}{CRC32});
}
}
@@ -769,262 +772,6 @@ sub _dosToUnixTime
return $time_t;
}
-#sub scanCentralDirectory
-#{
-# # Use cases
-# # 1 32-bit CD
-# # 2 64-bit CD
-#
-# my $self = shift ;
-#
-# my @CD = ();
-# my $offset = $self->findCentralDirectoryOffset();
-#
-# return 0
-# if ! defined $offset;
-#
-# $self->smarkSeek($offset, 0, SEEK_SET) ;
-#
-# # Now walk the Central Directory Records
-# my $buffer ;
-# while ($self->smartReadExact(\$buffer, 46) &&
-# unpack("V", $buffer) == ZIP_CENTRAL_HDR_SIG) {
-#
-# my $compressedLength = unpack ("V", substr($buffer, 20, 4));
-# my $filename_length = unpack ("v", substr($buffer, 28, 2));
-# my $extra_length = unpack ("v", substr($buffer, 30, 2));
-# my $comment_length = unpack ("v", substr($buffer, 32, 2));
-#
-# $self->smarkSeek($filename_length + $extra_length + $comment_length, 0, SEEK_CUR)
-# if $extra_length || $comment_length || $filename_length;
-# push @CD, $compressedLength ;
-# }
-#
-#}
-#
-#sub findCentralDirectoryOffset
-#{
-# my $self = shift ;
-#
-# # Most common use-case is where there is no comment, so
-# # know exactly where the end of central directory record
-# # should be.
-#
-# $self->smarkSeek(-22, 0, SEEK_END) ;
-#
-# my $buffer;
-# $self->smartReadExact(\$buffer, 22) ;
-#
-# my $zip64 = 0;
-# my $centralDirOffset ;
-# if ( unpack("V", $buffer) == ZIP_END_CENTRAL_HDR_SIG ) {
-# $centralDirOffset = unpack ("V", substr($buffer, 16, 2));
-# }
-# else {
-# die "xxxx";
-# }
-#
-# return $centralDirOffset ;
-#}
-#
-#sub is84BitCD
-#{
-# # TODO
-# my $self = shift ;
-#}
-
-
-sub skip
-{
- my $self = shift;
- my $size = shift;
-
- use Fcntl qw(SEEK_CUR);
- if (ref $size eq 'U64') {
- $self->smartSeek($size->get64bit(), SEEK_CUR);
- }
- else {
- $self->smartSeek($size, SEEK_CUR);
- }
-
-}
-
-
-sub scanCentralDirectory
-{
- my $self = shift;
-
- my $here = $self->tell();
-
- # Use cases
- # 1 32-bit CD
- # 2 64-bit CD
-
- my @CD = ();
- my $offset = $self->findCentralDirectoryOffset();
-
- return ()
- if ! defined $offset;
-
- $self->smarkSeek($offset, 0, SEEK_SET) ;
-
- # Now walk the Central Directory Records
- my $buffer ;
- while ($self->smartReadExact(\$buffer, 46) &&
- unpack("V", $buffer) == ZIP_CENTRAL_HDR_SIG) {
-
- my $compressedLength = unpack("V", substr($buffer, 20, 4));
- my $uncompressedLength = unpack("V", substr($buffer, 24, 4));
- my $filename_length = unpack("v", substr($buffer, 28, 2));
- my $extra_length = unpack("v", substr($buffer, 30, 2));
- my $comment_length = unpack("v", substr($buffer, 32, 2));
-
- $self->skip($filename_length ) ;
-
- my $v64 = new U64 $compressedLength ;
-
- if (U64::full32 $compressedLength ) {
- $self->smartReadExact(\$buffer, $extra_length) ;
- die "xxx $offset $comment_length $filename_length $extra_length" . length($buffer)
- if length($buffer) != $extra_length;
- my $got = $self->get64Extra($buffer, U64::full32 $uncompressedLength);
-
- # If not Zip64 extra field, assume size is 0xFFFFFFFF
- $v64 = $got if defined $got;
- }
- else {
- $self->skip($extra_length) ;
- }
-
- $self->skip($comment_length ) ;
-
- push @CD, $v64 ;
- }
-
- $self->smartSeek($here, 0, SEEK_SET) ;
-
- return @CD;
-}
-
-sub get64Extra
-{
- my $self = shift ;
-
- my $buffer = shift;
- my $is_uncomp = shift ;
-
- my $extra = IO::Compress::Zlib::Extra::findID(0x0001, $buffer);
-
- if (! defined $extra)
- {
- return undef;
- }
- else
- {
- my $u64 = U64::newUnpack_V64(substr($extra, $is_uncomp ? 8 : 0)) ;
- return $u64;
- }
-}
-
-sub offsetFromZip64
-{
- my $self = shift ;
- my $here = shift;
-
- $self->smartSeek($here - 20, 0, SEEK_SET)
- or die "xx $!" ;
-
- my $buffer;
- my $got = 0;
- $self->smartReadExact(\$buffer, 20)
- or die "xxx $here $got $!" ;
-
- if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_LOC_HDR_SIG ) {
- my $cd64 = U64::Value_VV64 substr($buffer, 8, 8);
-
- $self->smartSeek($cd64, 0, SEEK_SET) ;
-
- $self->smartReadExact(\$buffer, 4)
- or die "xxx" ;
-
- if ( unpack("V", $buffer) == ZIP64_END_CENTRAL_REC_HDR_SIG ) {
-
- $self->smartReadExact(\$buffer, 8)
- or die "xxx" ;
- my $size = U64::Value_VV64($buffer);
- $self->smartReadExact(\$buffer, $size)
- or die "xxx" ;
-
- my $cd64 = U64::Value_VV64 substr($buffer, 36, 8);
-
- return $cd64 ;
- }
-
- die "zzz";
- }
-
- die "zzz";
-}
-
-use constant Pack_ZIP_END_CENTRAL_HDR_SIG => pack("V", ZIP_END_CENTRAL_HDR_SIG);
-
-sub findCentralDirectoryOffset
-{
- my $self = shift ;
-
- # Most common use-case is where there is no comment, so
- # know exactly where the end of central directory record
- # should be.
-
- $self->smartSeek(-22, 0, SEEK_END) ;
- my $here = $self->tell();
-
- my $buffer;
- $self->smartReadExact(\$buffer, 22)
- or die "xxx" ;
-
- my $zip64 = 0;
- my $centralDirOffset ;
- if ( unpack("V", $buffer) == ZIP_END_CENTRAL_HDR_SIG ) {
- $centralDirOffset = unpack("V", substr($buffer, 16, 4));
- }
- else {
- $self->smartSeek(0, 0, SEEK_END) ;
-
- my $fileLen = $self->tell();
- my $want = 0 ;
-
- while(1) {
- $want += 1024;
- my $seekTo = $fileLen - $want;
- if ($seekTo < 0 ) {
- $seekTo = 0;
- $want = $fileLen ;
- }
- $self->smartSeek( $seekTo, 0, SEEK_SET)
- or die "xxx $!" ;
- my $got;
- $self->smartReadExact($buffer, $want)
- or die "xxx " ;
- my $pos = rindex( $buffer, Pack_ZIP_END_CENTRAL_HDR_SIG);
-
- if ($pos >= 0) {
- #$here = $self->tell();
- $here = $seekTo + $pos ;
- $centralDirOffset = unpack("V", substr($buffer, $pos + 16, 4));
- last ;
- }
-
- return undef
- if $want == $fileLen;
- }
- }
-
- $centralDirOffset = $self->offsetFromZip64($here)
- if U64::full32 $centralDirOffset ;
-
- return $centralDirOffset ;
-}
1;
@@ -1096,20 +843,19 @@ section.
use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
- unzip $input_filename_or_reference => $output_filename_or_reference [,OPTS]
+ unzip $input => $output [,OPTS]
or die "unzip failed: $UnzipError\n";
The functional interface needs Perl5.005 or better.
-=head2 unzip $input_filename_or_reference => $output_filename_or_reference [, OPTS]
+=head2 unzip $input => $output [, OPTS]
-C<unzip> expects at least two parameters,
-C<$input_filename_or_reference> and C<$output_filename_or_reference>.
+C<unzip> expects at least two parameters, C<$input> and C<$output>.
-=head3 The C<$input_filename_or_reference> parameter
+=head3 The C<$input> parameter
-The parameter, C<$input_filename_or_reference>, is used to define the
-source of the compressed data.
+The parameter, C<$input>, is used to define the source of
+the compressed data.
It can take one of the following forms:
@@ -1117,25 +863,25 @@ It can take one of the following forms:
=item A filename
-If the <$input_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for reading and the
-input data will be read from it.
+If the C<$input> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for reading and the input data
+will be read from it.
=item A filehandle
-If the C<$input_filename_or_reference> parameter is a filehandle, the input
-data will be read from it. The string '-' can be used as an alias for
-standard input.
+If the C<$input> parameter is a filehandle, the input data will be
+read from it.
+The string '-' can be used as an alias for standard input.
=item A scalar reference
-If C<$input_filename_or_reference> is a scalar reference, the input data
-will be read from C<$$input_filename_or_reference>.
+If C<$input> is a scalar reference, the input data will be read
+from C<$$input>.
=item An array reference
-If C<$input_filename_or_reference> is an array reference, each element in
-the array must be a filename.
+If C<$input> is an array reference, each element in the array must be a
+filename.
The input data will be read from each file in turn.
@@ -1144,71 +890,64 @@ contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
-If C<$input_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<unzip> will assume that it is an
-I<input fileglob string>. The input is the list of files that match the
-fileglob.
+If C<$input> is a string that is delimited by the characters "<" and ">"
+C<unzip> will assume that it is an I<input fileglob string>. The
+input is the list of files that match the fileglob.
+
+If the fileglob does not match any files ...
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
-If the C<$input_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$input> parameter is any other type, C<undef> will be returned.
-=head3 The C<$output_filename_or_reference> parameter
+=head3 The C<$output> parameter
-The parameter C<$output_filename_or_reference> is used to control the
-destination of the uncompressed data. This parameter can take one of
-these forms.
+The parameter C<$output> is used to control the destination of the
+uncompressed data. This parameter can take one of these forms.
=over 5
=item A filename
-If the C<$output_filename_or_reference> parameter is a simple scalar, it is
-assumed to be a filename. This file will be opened for writing and the
-uncompressed data will be written to it.
+If the C<$output> parameter is a simple scalar, it is assumed to be a
+filename. This file will be opened for writing and the uncompressed
+data will be written to it.
=item A filehandle
-If the C<$output_filename_or_reference> parameter is a filehandle, the
-uncompressed data will be written to it. The string '-' can be used as
-an alias for standard output.
+If the C<$output> parameter is a filehandle, the uncompressed data
+will be written to it.
+The string '-' can be used as an alias for standard output.
=item A scalar reference
-If C<$output_filename_or_reference> is a scalar reference, the
-uncompressed data will be stored in C<$$output_filename_or_reference>.
+If C<$output> is a scalar reference, the uncompressed data will be
+stored in C<$$output>.
=item An Array Reference
-If C<$output_filename_or_reference> is an array reference,
-the uncompressed data will be pushed onto the array.
+If C<$output> is an array reference, the uncompressed data will be
+pushed onto the array.
=item An Output FileGlob
-If C<$output_filename_or_reference> is a string that is delimited by the
-characters "<" and ">" C<unzip> will assume that it is an
-I<output fileglob string>. The output is the list of files that match the
-fileglob.
+If C<$output> is a string that is delimited by the characters "<" and ">"
+C<unzip> will assume that it is an I<output fileglob string>. The
+output is the list of files that match the fileglob.
-When C<$output_filename_or_reference> is an fileglob string,
-C<$input_filename_or_reference> must also be a fileglob string. Anything
-else is an error.
-
-See L<File::GlobMapper|File::GlobMapper> for more details.
+When C<$output> is an fileglob string, C<$input> must also be a fileglob
+string. Anything else is an error.
=back
-If the C<$output_filename_or_reference> parameter is any other type,
-C<undef> will be returned.
+If the C<$output> parameter is any other type, C<undef> will be returned.
=head2 Notes
-When C<$input_filename_or_reference> maps to multiple compressed
-files/buffers and C<$output_filename_or_reference> is
-a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
+When C<$input> maps to multiple compressed files/buffers and C<$output> is
+a single file/buffer, after uncompression C<$output> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
@@ -1270,8 +1009,8 @@ data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
-appending. If the output is a buffer, all uncompressed data will be
-appended to the existing buffer.
+appending. If the output is a buffer, all uncompressed data will be appened to
+the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
@@ -1317,57 +1056,54 @@ C<InputLength> option.
=head2 Examples
-Say you have a zip file, C<file1.zip>, that only contains a
-single member, you can read it and write the uncompressed data to the
-file C<file1.txt> like this.
+To read the contents of the file C<file1.txt.zip> and write the
+uncompressed data to the file C<file1.txt>.
use strict ;
use warnings ;
use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
- my $input = "file1.zip";
+ my $input = "file1.txt.zip";
my $output = "file1.txt";
unzip $input => $output
or die "unzip failed: $UnzipError\n";
-If you have a zip file that contains multiple members and want to read a
-specific member from the file, say C<"data1">, use the C<Name> option
+To read from an existing Perl filehandle, C<$input>, and write the
+uncompressed data to a buffer, C<$buffer>.
use strict ;
use warnings ;
use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
+ use IO::File ;
- my $input = "file1.zip";
- my $output = "file1.txt";
- unzip $input => $output, Name => "data1"
+ my $input = new IO::File "<file1.txt.zip"
+ or die "Cannot open 'file1.txt.zip': $!\n" ;
+ my $buffer ;
+ unzip $input => \$buffer
or die "unzip failed: $UnzipError\n";
-Alternatively, if you want to read the C<"data1"> member into memory, use
-a scalar reference for the C<output> parameter.
+To uncompress all files in the directory "/my/home" that match "*.txt.zip" and store the compressed data in the same directory
use strict ;
use warnings ;
use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
- my $input = "file1.zip";
- my $output ;
- unzip $input => \$output, Name => "data1"
+ unzip '</my/home/*.txt.zip>' => '</my/home/#1.txt>'
or die "unzip failed: $UnzipError\n";
- # $output now contains the uncompressed data
-To read from an existing Perl filehandle, C<$input>, and write the
-uncompressed data to a buffer, C<$buffer>.
+and if you want to compress each file one at a time, this will do the trick
use strict ;
use warnings ;
use IO::Uncompress::Unzip qw(unzip $UnzipError) ;
- use IO::File ;
- my $input = new IO::File "<file1.zip"
- or die "Cannot open 'file1.zip': $!\n" ;
- my $buffer ;
- unzip $input => \$buffer
- or die "unzip failed: $UnzipError\n";
+ for my $input ( glob "/my/home/*.txt.zip" )
+ {
+ my $output = $input;
+ $output =~ s/.zip// ;
+ unzip $input => $output
+ or die "Error compressing '$input': $UnzipError\n";
+ }
=head1 OO Interface
@@ -1409,7 +1145,7 @@ The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
-C<$$input>.
+C<$$output>.
=back
@@ -1427,10 +1163,6 @@ OPTS is a combination of the following options:
=over 5
-=item C<< Name => "membername" >>
-
-Open "membername" from the zip file for reading.
-
=item C<< AutoClose => 0|1 >>
This option is only valid when the C<$input> parameter is a filehandle. If
@@ -1467,7 +1199,7 @@ the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
-will make this module treat the whole file/buffer as a single data stream.
+will make this module treat the whole file/bufffer as a single data stream.
This option defaults to 1.
@@ -1526,7 +1258,7 @@ Usage is
$status = $z->read($buffer)
-Reads a block of compressed data (the size of the compressed block is
+Reads a block of compressed data (the size the the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
@@ -1564,7 +1296,7 @@ Usage is
Reads a single line.
-This method fully supports the use of the variable C<$/> (or
+This method fully supports the use of of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
@@ -1629,13 +1361,6 @@ Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
-Note that the implementation of C<seek> in this module does not provide
-true random access to a compressed file/buffer. It works by uncompressing
-data from the current offset in the file/buffer until it reaches the
-uncompressed offset specified in the parameters to C<seek>. For very small
-files this may be acceptable behaviour. For large files it may cause an
-unacceptable delay.
-
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
@@ -1681,7 +1406,7 @@ Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
-The contents of C<$/> are used to determine what constitutes a line
+The contents of C<$/> are used to to determine what constitutes a line
terminator.
=head2 fileno
@@ -1693,7 +1418,7 @@ If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
-If the C<$z> object is associated with a buffer, this method will return
+If the C<$z> object is is associated with a buffer, this method will return
C<undef>.
=head2 close
@@ -1782,57 +1507,13 @@ Same as doing this
=head2 Working with Net::FTP
-See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
-
-=head2 Walking through a zip file
-
-The code below can be used to traverse a zip file, one compressed data
-stream at a time.
-
- use IO::Uncompress::Unzip qw($UnzipError);
-
- my $zipfile = "somefile.zip";
- my $u = new IO::Uncompress::Unzip $zipfile
- or die "Cannot open $zipfile: $UnzipError";
-
- my $status;
- for ($status = 1; $status > 0; $status = $u->nextStream())
- {
-
- my $name = $u->getHeaderInfo()->{Name};
- warn "Processing member $name\n" ;
-
- my $buff;
- while (($status = $u->read($buff)) > 0) {
- # Do something here
- }
-
- last if $status < 0;
- }
-
- die "Error processing $zipfile: $!\n"
- if $status < 0 ;
-
-Each individual compressed data stream is read until the logical
-end-of-file is reached. Then C<nextStream> is called. This will skip to the
-start of the next compressed data stream and clear the end-of-file flag.
-
-It is also worth noting that C<nextStream> can be called at any time -- you
-don't have to wait until you have exhausted a compressed data stream before
-skipping to the next one.
-
-=head2 Unzipping a complete zip file to disk
-
-Daniel S. Sterling has written a script that uses C<IO::Uncompress::UnZip>
-to read a zip file and unzip its contents to disk.
-
-The script is available from L<https://gist.github.com/eqhmcow/5389877>
+See L<IO::Uncompress::Unzip::FAQ|IO::Uncompress::Unzip::FAQ/"Compressed files and Net::FTP">
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
-L<IO::Compress::FAQ|IO::Compress::FAQ>
+L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
@@ -1861,7 +1542,7 @@ See the Changes file.
=head1 COPYRIGHT AND LICENSE
-Copyright (c) 2005-2014 Paul Marquess. All rights reserved.
+Copyright (c) 2005-2010 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm
index 6a82bdff9bd..e60c93fda24 100644
--- a/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm
+++ b/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm
@@ -4,27 +4,24 @@ use strict;
BEGIN {
- use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
+ use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0;
use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut';
use constant SPECIAL_CHARS => qw[< > | &];
- use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
+ use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
use Exporter ();
use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
$USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
- $INSTANCES $ALLOW_NULL_ARGS
- $HAVE_MONOTONIC
];
- $VERSION = '0.92';
+ $VERSION = '0.54';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
$USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
$USE_IPC_OPEN3 = not IS_VMS;
- $ALLOW_NULL_ARGS = 0;
$CAN_USE_RUN_FORKED = 0;
eval {
@@ -33,22 +30,11 @@ BEGIN {
require IO::Select; IO::Select->import();
require IO::Handle; IO::Handle->import();
require FileHandle; FileHandle->import();
- require Socket;
+ require Socket; Socket->import();
require Time::HiRes; Time::HiRes->import();
- require Win32 if IS_WIN32;
};
$CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
- eval {
- my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
- };
- if ($@) {
- $HAVE_MONOTONIC = 0;
- }
- else {
- $HAVE_MONOTONIC = 1;
- }
-
@ISA = qw[Exporter];
@EXPORT_OK = qw[can_run run run_forked QUOTE];
}
@@ -88,7 +74,7 @@ IPC::Cmd - finding and running system commands made easy
### in list context ###
- my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
+ my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
run( command => $cmd, verbose => 0 );
if( $success ) {
@@ -96,84 +82,78 @@ IPC::Cmd - finding and running system commands made easy
print join "", @$full_buf;
}
- ### run_forked example ###
- my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20});
- if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) {
- print "this is what wget returned:\n";
- print $result->{'stdout'};
- }
-
### check for features
- print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
- print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
- print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
+ print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
+ print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
+ print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
### don't have IPC::Cmd be verbose, ie don't print to stdout or
### stderr when running commands -- default is '0'
$IPC::Cmd::VERBOSE = 0;
-
+
=head1 DESCRIPTION
-IPC::Cmd allows you to run commands platform independently,
-interactively if desired, but have them still work.
+IPC::Cmd allows you to run commands, interactively if desired,
+platform independent but have them still work.
The C<can_run> function can tell you if a certain binary is installed
and if so where, whereas the C<run> function can actually execute any
of the commands you give it and give you a clear return value, as well
as adhere to your verbosity settings.
-=head1 CLASS METHODS
+=head1 CLASS METHODS
=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
-Utility function that tells you if C<IPC::Run> is available.
-If the C<verbose> flag is passed, it will print diagnostic messages
-if L<IPC::Run> can not be found or loaded.
+Utility function that tells you if C<IPC::Run> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Run> can not be found or loaded.
=cut
-sub can_use_ipc_run {
+sub can_use_ipc_run {
my $self = shift;
my $verbose = shift || 0;
-
- ### IPC::Run doesn't run on win98
+
+ ### ipc::run doesn't run on win98
return if IS_WIN98;
- ### if we don't have ipc::run, we obviously can't use it.
+ ### if we dont have ipc::run, we obviously can't use it.
return unless can_load(
- modules => { 'IPC::Run' => '0.55' },
+ modules => { 'IPC::Run' => '0.55' },
verbose => ($WARN && $verbose),
);
-
+
### otherwise, we're good to go
- return $IPC::Run::VERSION;
+ return $IPC::Run::VERSION;
}
=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
-Utility function that tells you if C<IPC::Open3> is available.
+Utility function that tells you if C<IPC::Open3> is available.
If the verbose flag is passed, it will print diagnostic messages
if C<IPC::Open3> can not be found or loaded.
=cut
-sub can_use_ipc_open3 {
+sub can_use_ipc_open3 {
my $self = shift;
my $verbose = shift || 0;
- ### IPC::Open3 is not working on VMS because of a lack of fork.
+ ### ipc::open3 is not working on VMS becasue of a lack of fork.
+ ### XXX todo, win32 also does not have fork, so need to do more research.
return if IS_VMS;
- ### IPC::Open3 works on every non-VMS platform, but it can't
+ ### ipc::open3 works on every non-VMS platform platform, but it can't
### capture buffers on win32 :(
return unless can_load(
modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
verbose => ($WARN && $verbose),
);
-
+
return $IPC::Open3::VERSION;
}
@@ -187,8 +167,8 @@ capturing buffers in it's current configuration.
sub can_capture_buffer {
my $self = shift;
- return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
- return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3;
+ return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
+ return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3 && !IS_WIN32;
return;
}
@@ -201,20 +181,16 @@ providing C<run_forked> on the current platform.
=head2 $path = can_run( PROGRAM );
-C<can_run> takes only one argument: the name of a binary you wish
+C<can_run> takes but a single argument: the name of a binary you wish
to locate. C<can_run> works much like the unix binary C<which> or the bash
command C<type>, which scans through your path, looking for the requested
-binary.
+binary .
Unlike C<which> and C<type>, this function is platform independent and
will also work on, for example, Win32.
-If called in a scalar context it will return the full path to the binary
-you asked for if it was found, or C<undef> if it was not.
-
-If called in a list context and the global variable C<$INSTANCES> is a true
-value, it will return a list of the full paths to instances
-of the binary where found in C<PATH>, or an empty list if it was not found.
+It will return the full path to the binary you asked for if it was
+found, or C<undef> if it was not.
=cut
@@ -229,26 +205,22 @@ sub can_run {
return $command if scalar $syms->getsym( uc $command );
}
+ require Config;
require File::Spec;
require ExtUtils::MakeMaker;
- my @possibles;
-
if( File::Spec->file_name_is_absolute($command) ) {
return MM->maybe_command($command);
} else {
for my $dir (
- File::Spec->path,
+ (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
File::Spec->curdir
- ) {
- next if ! $dir || ! -d $dir;
- my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
- push @possibles, $abs if $abs = MM->maybe_command($abs);
+ ) {
+ my $abs = File::Spec->catfile($dir, $command);
+ return $abs if $abs = MM->maybe_command($abs);
}
}
- return @possibles if wantarray and $INSTANCES;
- return shift @possibles;
}
=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
@@ -263,15 +235,15 @@ This is the command to execute. It may be either a string or an array
reference.
This is a required argument.
-See L<"Caveats"> for remarks on how commands are parsed and their
+See L<CAVEATS> for remarks on how commands are parsed and their
limitations.
=item verbose
This controls whether all output of a command should also be printed
to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
-require L<IPC::Run> to be installed, or your system able to work with
-L<IPC::Open3>).
+require C<IPC::Run> to be installed or your system able to work with
+C<IPC::Open3>).
It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
which by default is 0.
@@ -286,14 +258,14 @@ If you require this distinction, run the C<run> command in list context
and inspect the individual buffers.
Of course, this requires that the underlying call supports buffers. See
-the note on buffers above.
+the note on buffers right above.
=item timeout
Sets the maximum time the command is allowed to run before aborting,
using the built-in C<alarm()> call. If the timeout is triggered, the
-C<errorcode> in the return value will be set to an object of the
-C<IPC::Cmd::TimeOut> class. See the L<"error message"> section below for
+C<errorcode> in the return value will be set to an object of the
+C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
details.
Defaults to C<0>, meaning no timeout is set.
@@ -313,42 +285,47 @@ not.
=item error message
-If the first element of the return value (C<success>) was 0, then some
+If the first element of the return value (success) was 0, then some
error occurred. This second element is the error message the command
-you requested exited with, if available. This is generally a pretty
-printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
+you requested exited with, if available. This is generally a pretty
+printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
what they can contain.
If the error was a timeout, the C<error message> will be prefixed with
the string C<IPC::Cmd::TimeOut>, the timeout class.
=item full_buffer
-This is an array reference containing all the output the command
+This is an arrayreference containing all the output the command
generated.
-Note that buffers are only available if you have L<IPC::Run> installed,
-or if your system is able to work with L<IPC::Open3> -- see below).
-Otherwise, this element will be C<undef>.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
=item out_buffer
-This is an array reference containing all the output sent to STDOUT the
-command generated. The notes from L<"full_buffer"> apply.
+This is an arrayreference containing all the output sent to STDOUT the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
=item error_buffer
This is an arrayreference containing all the output sent to STDERR the
-command generated. The notes from L<"full_buffer"> apply.
-
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
=back
-See the L<"HOW IT WORKS"> section below to see how C<IPC::Cmd> decides
+See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> decides
what modules or function calls to use when issuing a command.
=cut
{ my @acc = qw[ok error _fds];
-
+
### autogenerate accessors ###
for my $key ( @acc ) {
no strict 'refs';
@@ -363,326 +340,181 @@ sub can_use_run_forked {
return $CAN_USE_RUN_FORKED eq "1";
}
-sub get_monotonic_time {
- if ($HAVE_MONOTONIC) {
- return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
- }
- else {
- return time();
- }
-}
-
-sub adjust_monotonic_start_time {
- my ($ref_vars, $now, $previous) = @_;
-
- # workaround only for those systems which don't have
- # Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular)
- return if $HAVE_MONOTONIC;
-
- # don't have previous monotonic value (only happens once
- # in the beginning of the program execution)
- return unless $previous;
-
- my $time_diff = $now - $previous;
-
- # adjust previously saved time with the skew value which is
- # either negative when clock moved back or more than 5 seconds --
- # assuming that event loop does happen more often than once
- # per five seconds, which might not be always true (!) but
- # hopefully that's ok, because it's just a workaround
- if ($time_diff > 5 || $time_diff < 0) {
- foreach my $ref_var (@{$ref_vars}) {
- if (defined($$ref_var)) {
- $$ref_var = $$ref_var + $time_diff;
- }
- }
- }
-}
-
-# incompatible with POSIX::SigAction
-#
-sub install_layered_signal {
- my ($s, $handler_code) = @_;
-
- my %available_signals = map {$_ => 1} keys %SIG;
-
- Carp::confess("install_layered_signal got nonexistent signal name [$s]")
- unless defined($available_signals{$s});
- Carp::confess("install_layered_signal expects coderef")
- if !ref($handler_code) || ref($handler_code) ne 'CODE';
-
- my $previous_handler = $SIG{$s};
-
- my $sig_handler = sub {
- my ($called_sig_name, @sig_param) = @_;
-
- # $s is a closure referring to real signal name
- # for which this handler is being installed.
- # it is used to distinguish between
- # real signal handlers and aliased signal handlers
- my $signal_name = $s;
-
- # $called_sig_name is a signal name which
- # was passed to this signal handler;
- # it doesn't equal $signal_name in case
- # some signal handlers in %SIG point
- # to other signal handler (CHLD and CLD,
- # ABRT and IOT)
- #
- # initial signal handler for aliased signal
- # calls some other signal handler which
- # should not execute the same handler_code again
- if ($called_sig_name eq $signal_name) {
- $handler_code->($signal_name);
- }
-
- # run original signal handler if any (including aliased)
- #
- if (ref($previous_handler)) {
- $previous_handler->($called_sig_name, @sig_param);
- }
- };
-
- $SIG{$s} = $sig_handler;
-}
-
# give process a chance sending TERM,
# waiting for a while (2 seconds)
# and killing it with KILL
sub kill_gently {
- my ($pid, $opts) = @_;
-
- require POSIX;
-
- $opts = {} unless $opts;
- $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
- $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
- $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};
-
- if ($opts->{'first_kill_type'} eq 'just_process') {
- kill(15, $pid);
- }
- elsif ($opts->{'first_kill_type'} eq 'process_group') {
- kill(-15, $pid);
- }
-
- my $do_wait = 1;
+ my ($pid) = @_;
+
+ kill(15, $pid);
+
+ my $wait_cycles = 0;
my $child_finished = 0;
- my $wait_start_time = get_monotonic_time();
- my $now;
- my $previous_monotonic_value;
-
- while ($do_wait) {
- $previous_monotonic_value = $now;
- $now = get_monotonic_time();
-
- adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value);
-
- if ($now > $wait_start_time + $opts->{'wait_time'}) {
- $do_wait = 0;
- next;
- }
-
- my $waitpid = waitpid($pid, POSIX::WNOHANG);
-
+ while (!$child_finished && $wait_cycles < 8) {
+ my $waitpid = waitpid($pid, WNOHANG);
if ($waitpid eq -1) {
- $child_finished = 1;
- $do_wait = 0;
- next;
+ $child_finished = 1;
}
-
- Time::HiRes::usleep(250000); # quarter of a second
- }
- if (!$child_finished) {
- if ($opts->{'final_kill_type'} eq 'just_process') {
- kill(9, $pid);
- }
- elsif ($opts->{'final_kill_type'} eq 'process_group') {
- kill(-9, $pid);
- }
+ $wait_cycles = $wait_cycles + 1;
+ Time::HiRes::usleep(250000); # half a second
}
}
sub open3_run {
- my ($cmd, $opts) = @_;
+ my ($cmd, $opts) = @_;
- $opts = {} unless $opts;
+ $opts = {} unless $opts;
+
+ my $child_in = FileHandle->new;
+ my $child_out = FileHandle->new;
+ my $child_err = FileHandle->new;
+ $child_out->autoflush(1);
+ $child_err->autoflush(1);
+
+ my $pid = open3($child_in, $child_out, $child_err, $cmd);
+
+ # push my child's pid to our parent
+ # so in case i am killed parent
+ # could stop my child (search for
+ # child_child_pid in parent code)
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "spawned $pid\n";
+ }
- my $child_in = FileHandle->new;
- my $child_out = FileHandle->new;
- my $child_err = FileHandle->new;
- $child_out->autoflush(1);
- $child_err->autoflush(1);
-
- my $pid = open3($child_in, $child_out, $child_err, $cmd);
-
- # push my child's pid to our parent
- # so in case i am killed parent
- # could stop my child (search for
- # child_child_pid in parent code)
- if ($opts->{'parent_info'}) {
- my $ps = $opts->{'parent_info'};
- print $ps "spawned $pid\n";
- }
+ if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
- if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
- # If the child process dies for any reason,
- # the next write to CHLD_IN is likely to generate
- # a SIGPIPE in the parent, which is fatal by default.
- # So you may wish to handle this signal.
- #
- # from http://perldoc.perl.org/IPC/Open3.html,
- # absolutely needed to catch piped commands errors.
- #
- local $SIG{'PIPE'} = sub { 1; };
-
- print $child_in $opts->{'child_stdin'};
- }
- close($child_in);
-
- my $child_output = {
- 'out' => $child_out->fileno,
- 'err' => $child_err->fileno,
- $child_out->fileno => {
- 'parent_socket' => $opts->{'parent_stdout'},
- 'scalar_buffer' => "",
- 'child_handle' => $child_out,
- 'block_size' => ($child_out->stat)[11] || 1024,
- },
- $child_err->fileno => {
- 'parent_socket' => $opts->{'parent_stderr'},
- 'scalar_buffer' => "",
- 'child_handle' => $child_err,
- 'block_size' => ($child_err->stat)[11] || 1024,
- },
- };
+ # If the child process dies for any reason,
+ # the next write to CHLD_IN is likely to generate
+ # a SIGPIPE in the parent, which is fatal by default.
+ # So you may wish to handle this signal.
+ #
+ # from http://perldoc.perl.org/IPC/Open3.html,
+ # absolutely needed to catch piped commands errors.
+ #
+ local $SIG{'SIG_PIPE'} = sub { 1; };
+
+ print $child_in $opts->{'child_stdin'};
+ }
+ close($child_in);
+
+ my $child_output = {
+ 'out' => $child_out->fileno,
+ 'err' => $child_err->fileno,
+ $child_out->fileno => {
+ 'parent_socket' => $opts->{'parent_stdout'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_out,
+ 'block_size' => ($child_out->stat)[11] || 1024,
+ },
+ $child_err->fileno => {
+ 'parent_socket' => $opts->{'parent_stderr'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_err,
+ 'block_size' => ($child_err->stat)[11] || 1024,
+ },
+ };
- my $select = IO::Select->new();
- $select->add($child_out, $child_err);
-
- # pass any signal to the child
- # effectively creating process
- # strongly attached to the child:
- # it will terminate only after child
- # has terminated (except for SIGKILL,
- # which is specially handled)
- foreach my $s (keys %SIG) {
- my $sig_handler;
- $sig_handler = sub {
- kill("$s", $pid);
- $SIG{$s} = $sig_handler;
- };
- $SIG{$s} = $sig_handler;
- }
+ my $select = IO::Select->new();
+ $select->add($child_out, $child_err);
+
+ # pass any signal to the child
+ # effectively creating process
+ # strongly attached to the child:
+ # it will terminate only after child
+ # has terminated (except for SIGKILL,
+ # which is specially handled)
+ foreach my $s (keys %SIG) {
+ my $sig_handler;
+ $sig_handler = sub {
+ kill("$s", $pid);
+ $SIG{$s} = $sig_handler;
+ };
+ $SIG{$s} = $sig_handler;
+ }
- my $child_finished = 0;
+ my $child_finished = 0;
- my $real_exit;
- my $exit_value;
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
- while(!$child_finished) {
+ while(!$child_finished && ($child_out->opened || $child_err->opened)) {
- # parent was killed otherwise we would have got
- # the same signal as parent and process it same way
- if (getppid() eq "1") {
+ # parent was killed otherwise we would have got
+ # the same signal as parent and process it same way
+ if (getppid() eq "1") {
+ kill_gently($pid);
+ exit;
+ }
- # end my process group with all the children
- # (i am the process group leader, so my pid
- # equals to the process group id)
- #
- # same thing which is done
- # with $opts->{'clean_up_children'}
- # in run_forked
- #
- kill(-9, $$);
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
- POSIX::_exit 1;
- }
+ Time::HiRes::usleep(1);
- my $waitpid = waitpid($pid, POSIX::WNOHANG);
+ foreach my $fd ($select->can_read(1/100)) {
+ my $str = $child_output->{$fd->fileno};
+ psSnake::die("child stream not found: $fd") unless $str;
- # child finished, catch it's exit status
- if ($waitpid ne 0 && $waitpid ne -1) {
- $real_exit = $?;
- $exit_value = $? >> 8;
- }
+ my $data;
+ my $count = $fd->sysread($data, $str->{'block_size'});
- if ($waitpid eq -1) {
- $child_finished = 1;
+ if ($count) {
+ if ($str->{'parent_socket'}) {
+ my $ph = $str->{'parent_socket'};
+ print $ph $data;
}
-
-
- my $ready_fds = [];
- push @{$ready_fds}, $select->can_read(1/100);
-
- READY_FDS: while (scalar(@{$ready_fds})) {
- my $fd = shift @{$ready_fds};
- $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
-
- my $str = $child_output->{$fd->fileno};
- Carp::confess("child stream not found: $fd") unless $str;
-
- my $data;
- my $count = $fd->sysread($data, $str->{'block_size'});
-
- if ($count) {
- if ($str->{'parent_socket'}) {
- my $ph = $str->{'parent_socket'};
- print $ph $data;
- }
- else {
- $str->{'scalar_buffer'} .= $data;
- }
- }
- elsif ($count eq 0) {
- $select->remove($fd);
- $fd->close();
- }
- else {
- Carp::confess("error during sysread: " . $!);
- }
-
- push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
+ else {
+ $str->{'scalar_buffer'} .= $data;
}
-
- Time::HiRes::usleep(1);
+ }
+ elsif ($count eq 0) {
+ $select->remove($fd);
+ $fd->close();
+ }
+ else {
+ psSnake::die("error during sysread: " . $!);
+ }
}
+ }
- # since we've successfully reaped the child,
- # let our parent know about this.
- #
- if ($opts->{'parent_info'}) {
- my $ps = $opts->{'parent_info'};
-
- # child was killed, inform parent
- if ($real_exit & 127) {
- print $ps "$pid killed with " . ($real_exit & 127) . "\n";
- }
+ waitpid($pid, 0);
- print $ps "reaped $pid\n";
- }
+ # i've successfully reaped my child,
+ # let my parent know this
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "reaped $pid\n";
+ }
- if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
- return $exit_value;
- }
- else {
- return {
- 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
- 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
- 'exit_code' => $exit_value,
- };
- }
+ my $real_exit = $?;
+ my $exit_value = $real_exit >> 8;
+ if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
+ return $exit_value;
+ }
+ else {
+ return {
+ 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
+ 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
+ 'exit_code' => $exit_value,
+ };
+ }
}
-=head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
+=head2 $hashref = run_forked( command => COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
-C<run_forked> is used to execute some program or a coderef,
+C<run_forked> is used to execute some program,
optionally feed it with some input, get its return code
-and output (both stdout and stderr into separate buffers).
-In addition, it allows to terminate the program
-if it takes too long to finish.
+and output (both stdout and stderr into seperate buffers).
+In addition it allows to terminate the program
+which take too long to finish.
The important and distinguishing feature of run_forked
is execution timeout which at first seems to be
@@ -704,40 +536,28 @@ feeds it with input, stores its exit code,
stdout and stderr, terminates it in case
it runs longer than specified.
-Invocation requires the command to be executed or a coderef and optionally a hashref of options:
+Invocation requires the command to be executed and optionally a hashref of options:
=over
=item C<timeout>
-Specify in seconds how long to run the command before it is killed with SIG_KILL (9),
+Specify in seconds how long the command may run for before it is killed with with SIG_KILL (9)
which effectively terminates it and all of its children (direct or indirect).
=item C<child_stdin>
-Specify some text that will be passed into the C<STDIN> of the executed program.
+Specify some text that will be passed into C<STDIN> of the executed program.
=item C<stdout_handler>
-Coderef of a subroutine to call when a portion of data is received on
-STDOUT from the executing program.
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stdout from the executing program.
=item C<stderr_handler>
-Coderef of a subroutine to call when a portion of data is received on
-STDERR from the executing program.
-
-
-=item C<discard_output>
-
-Discards the buffering of the standard output and standard errors for return by run_forked().
-With this option you have to use the std*_handlers to read what the command outputs.
-Useful for commands that send a lot of output.
-
-=item C<terminate_on_parent_sudden_death>
-
-Enable this option if you wish all spawned processes to be killed if the initially spawned
-process (the parent) is killed or dies without waiting for child processes.
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stderr from the executing program.
=back
@@ -755,18 +575,18 @@ The number of seconds the program ran for before being terminated, or 0 if no ti
=item C<stdout>
-Holds the standard output of the executed command (or empty string if
-there was no STDOUT output or if C<discard_output> was used; it's always defined!)
+Holds the standard output of the executed command
+(or empty string if there were no stdout output; it's always defined!)
=item C<stderr>
-Holds the standard error of the executed command (or empty string if
-there was no STDERR output or if C<discard_output> was used; it's always defined!)
+Holds the standard error of the executed command
+(or empty string if there were no stderr output; it's always defined!)
=item C<merged>
Holds the standard output and error of the executed command merged into one stream
-(or empty string if there was no output at all or if C<discard_output> was used; it's always defined!)
+(or empty string if there were no output at all; it's always defined!)
=item C<err_msg>
@@ -785,12 +605,7 @@ sub run_forked {
return;
}
- require POSIX;
-
my ($cmd, $opts) = @_;
- if (ref($cmd) eq 'ARRAY') {
- $cmd = join(" ", @{$cmd});
- }
if (!$cmd) {
Carp::carp("run_forked expects command to run");
@@ -799,10 +614,6 @@ sub run_forked {
$opts = {} unless $opts;
$opts->{'timeout'} = 0 unless $opts->{'timeout'};
- $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
-
- # turned on by default
- $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
# sockets to pass child stdout to parent
my $child_stdout_socket;
@@ -811,17 +622,17 @@ sub run_forked {
# sockets to pass child stderr to parent
my $child_stderr_socket;
my $parent_stderr_socket;
-
+
# sockets for child -> parent internal communication
my $child_info_socket;
my $parent_info_socket;
- socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
- Carp::confess ("socketpair: $!");
- socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
- Carp::confess ("socketpair: $!");
- socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
- Carp::confess ("socketpair: $!");
+ socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
$child_stdout_socket->autoflush(1);
$parent_stdout_socket->autoflush(1);
@@ -830,7 +641,7 @@ sub run_forked {
$child_info_socket->autoflush(1);
$parent_info_socket->autoflush(1);
- my $start_time = get_monotonic_time();
+ my $start_time = time();
my $pid;
if ($pid = fork) {
@@ -840,105 +651,44 @@ sub run_forked {
close($parent_stderr_socket);
close($parent_info_socket);
+ my $child_timedout = 0;
my $flags;
# prepare sockets to read from child
$flags = 0;
- fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!";
- $flags |= POSIX::O_NONBLOCK;
- fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
+ fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
$flags = 0;
- fcntl($child_stderr_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!";
- $flags |= POSIX::O_NONBLOCK;
- fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
+ fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
$flags = 0;
- fcntl($child_info_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!";
- $flags |= POSIX::O_NONBLOCK;
- fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
+ fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
# print "child $pid started\n";
- my $child_output = {
- $child_stdout_socket->fileno => {
- 'scalar_buffer' => "",
- 'child_handle' => $child_stdout_socket,
- 'block_size' => ($child_stdout_socket->stat)[11] || 1024,
- 'protocol' => 'stdout',
- },
- $child_stderr_socket->fileno => {
- 'scalar_buffer' => "",
- 'child_handle' => $child_stderr_socket,
- 'block_size' => ($child_stderr_socket->stat)[11] || 1024,
- 'protocol' => 'stderr',
- },
- $child_info_socket->fileno => {
- 'scalar_buffer' => "",
- 'child_handle' => $child_info_socket,
- 'block_size' => ($child_info_socket->stat)[11] || 1024,
- 'protocol' => 'info',
- },
- };
-
- my $select = IO::Select->new();
- $select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket);
-
- my $child_timedout = 0;
my $child_finished = 0;
my $child_stdout = '';
my $child_stderr = '';
my $child_merged = '';
my $child_exit_code = 0;
- my $child_killed_by_signal = 0;
- my $parent_died = 0;
- my $last_parent_check = 0;
my $got_sig_child = 0;
- my $got_sig_quit = 0;
- my $orig_sig_child = $SIG{'CHLD'};
-
- $SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); };
-
- if ($opts->{'terminate_on_signal'}) {
- install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
- }
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
my $child_child_pid;
- my $now;
- my $previous_monotonic_value;
while (!$child_finished) {
- $previous_monotonic_value = $now;
- $now = get_monotonic_time();
-
- adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value);
-
- if ($opts->{'terminate_on_parent_sudden_death'}) {
- # check for parent once each five seconds
- if ($now > $last_parent_check + 5) {
- if (getppid() eq "1") {
- kill_gently ($pid, {
- 'first_kill_type' => 'process_group',
- 'final_kill_type' => 'process_group',
- 'wait_time' => $opts->{'terminate_wait_time'}
- });
- $parent_died = 1;
- }
-
- $last_parent_check = $now;
- }
- }
-
# user specified timeout
if ($opts->{'timeout'}) {
- if ($now > $start_time + $opts->{'timeout'}) {
- kill_gently ($pid, {
- 'first_kill_type' => 'process_group',
- 'final_kill_type' => 'process_group',
- 'wait_time' => $opts->{'terminate_wait_time'}
- });
+ if (time() - $start_time > $opts->{'timeout'}) {
+ kill (-9, $pid);
$child_timedout = 1;
}
}
@@ -947,23 +697,14 @@ sub run_forked {
# kill process after that and finish wait loop;
# shouldn't ever happen -- remove this code?
if ($got_sig_child) {
- if ($now > $got_sig_child + 10) {
+ if (time() - $got_sig_child > 10) {
print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
kill (-9, $pid);
$child_finished = 1;
}
}
- if ($got_sig_quit) {
- kill_gently ($pid, {
- 'first_kill_type' => 'process_group',
- 'final_kill_type' => 'process_group',
- 'wait_time' => $opts->{'terminate_wait_time'}
- });
- $child_finished = 1;
- }
-
- my $waitpid = waitpid($pid, POSIX::WNOHANG);
+ my $waitpid = waitpid($pid, WNOHANG);
# child finished, catch it's exit status
if ($waitpid ne 0 && $waitpid ne -1) {
@@ -972,95 +713,36 @@ sub run_forked {
if ($waitpid eq -1) {
$child_finished = 1;
+ next;
}
- my $ready_fds = [];
- push @{$ready_fds}, $select->can_read(1/100);
-
- READY_FDS: while (scalar(@{$ready_fds})) {
- my $fd = shift @{$ready_fds};
- $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
-
- my $str = $child_output->{$fd->fileno};
- Carp::confess("child stream not found: $fd") unless $str;
-
- my $data = "";
- my $count = $fd->sysread($data, $str->{'block_size'});
-
- if ($count) {
- # extract all the available lines and store the rest in temporary buffer
- if ($data =~ /(.+\n)([^\n]*)/so) {
- $data = $str->{'scalar_buffer'} . $1;
- $str->{'scalar_buffer'} = $2 || "";
- }
- else {
- $str->{'scalar_buffer'} .= $data;
- $data = "";
- }
+ # child -> parent simple internal communication protocol
+ while (my $l = <$child_info_socket>) {
+ if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = $1;
+ $l = $2;
}
- elsif ($count eq 0) {
- $select->remove($fd);
- $fd->close();
- if ($str->{'scalar_buffer'}) {
- $data = $str->{'scalar_buffer'} . "\n";
- }
- }
- else {
- Carp::confess("error during sysread on [$fd]: " . $!);
+ if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = undef;
+ $l = $2;
}
+ }
- # $data contains only full lines (or last line if it was unfinished read
- # or now new-line in the output of the child); dat is processed
- # according to the "protocol" of socket
- if ($str->{'protocol'} eq 'info') {
- if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) {
- $child_child_pid = $1;
- $data = $2;
- }
- if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) {
- $child_child_pid = undef;
- $data = $2;
- }
- if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
- $child_killed_by_signal = $1;
- $data = $2;
- }
+ while (my $l = <$child_stdout_socket>) {
+ $child_stdout .= $l;
+ $child_merged .= $l;
- # we don't expect any other data in info socket, so it's
- # some strange violation of protocol, better know about this
- if ($data) {
- Carp::confess("info protocol violation: [$data]");
- }
+ if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
+ $opts->{'stdout_handler'}->($l);
}
- if ($str->{'protocol'} eq 'stdout') {
- if (!$opts->{'discard_output'}) {
- $child_stdout .= $data;
- $child_merged .= $data;
- }
+ }
+ while (my $l = <$child_stderr_socket>) {
+ $child_stderr .= $l;
+ $child_merged .= $l;
- if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
- $opts->{'stdout_handler'}->($data);
- }
+ if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
+ $opts->{'stderr_handler'}->($l);
}
- if ($str->{'protocol'} eq 'stderr') {
- if (!$opts->{'discard_output'}) {
- $child_stderr .= $data;
- $child_merged .= $data;
- }
-
- if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
- $opts->{'stderr_handler'}->($data);
- }
- }
-
- # process may finish (waitpid returns -1) before
- # we've read all of its output because of buffering;
- # so try to read all the way it is possible to read
- # in such case - this shouldn't be too much (unless
- # the buffer size is HUGE -- should introduce
- # another counter in such case, maybe later)
- #
- push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
}
Time::HiRes::usleep(1);
@@ -1076,29 +758,12 @@ sub run_forked {
#
# defined $child_pid_pid means child's child
# has not died but nobody is waiting for it,
- # killing it brutally.
+ # killing it brutaly.
#
if ($child_child_pid) {
kill_gently($child_child_pid);
}
- # in case there are forks in child which
- # do not forward or process signals (TERM) correctly
- # kill whole child process group, effectively trying
- # not to return with some children or their parts still running
- #
- # to be more accurate -- we need to be sure
- # that this is process group created by our child
- # (and not some other process group with the same pgid,
- # created just after death of our child) -- fortunately
- # this might happen only when process group ids
- # are reused quickly (there are lots of processes
- # spawning new process groups for example)
- #
- if ($opts->{'clean_up_children'}) {
- kill(-9, $pid);
- }
-
# print "child $pid finished\n";
close($child_stdout_socket);
@@ -1111,10 +776,6 @@ sub run_forked {
'merged' => $child_merged,
'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
'exit_code' => $child_exit_code,
- 'parent_died' => $parent_died,
- 'killed_by_signal' => $child_killed_by_signal,
- 'child_pgid' => $pid,
- 'cmd' => $cmd,
};
my $err_msg = '';
@@ -1124,31 +785,18 @@ sub run_forked {
if ($o->{'timeout'}) {
$err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
}
- if ($o->{'parent_died'}) {
- $err_msg .= "parent died\n";
- }
- if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) {
+ if ($o->{'stdout'}) {
$err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
}
if ($o->{'stderr'}) {
$err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
}
- if ($o->{'killed_by_signal'}) {
- $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
- }
$o->{'err_msg'} = $err_msg;
- if ($orig_sig_child) {
- $SIG{'CHLD'} = $orig_sig_child;
- }
- else {
- delete($SIG{'CHLD'});
- }
-
return $o;
}
else {
- Carp::confess("cannot fork: $!") unless defined($pid);
+ die("cannot fork: $!") unless defined($pid);
# create new process session for open3 call,
# so we hopefully can kill all the subprocesses
@@ -1156,57 +804,24 @@ sub run_forked {
# which do setsid theirselves -- can't do anything
# with those)
- POSIX::setsid() || Carp::confess("Error running setsid: " . $!);
-
- if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
- $opts->{'child_BEGIN'}->();
- }
+ POSIX::setsid() || die("Error running setsid: " . $!);
close($child_stdout_socket);
close($child_stderr_socket);
close($child_info_socket);
- my $child_exit_code;
-
- # allow both external programs
- # and internal perl calls
- if (!ref($cmd)) {
- $child_exit_code = open3_run($cmd, {
- 'parent_info' => $parent_info_socket,
- 'parent_stdout' => $parent_stdout_socket,
- 'parent_stderr' => $parent_stderr_socket,
- 'child_stdin' => $opts->{'child_stdin'},
- });
- }
- elsif (ref($cmd) eq 'CODE') {
- # reopen STDOUT and STDERR for child code:
- # https://rt.cpan.org/Ticket/Display.html?id=85912
- open STDOUT, '>&', $parent_stdout_socket || Carp::confess("Unable to reopen STDOUT: $!\n");
- open STDERR, '>&', $parent_stderr_socket || Carp::confess("Unable to reopen STDERR: $!\n");
-
- $child_exit_code = $cmd->({
- 'opts' => $opts,
- 'parent_info' => $parent_info_socket,
- 'parent_stdout' => $parent_stdout_socket,
- 'parent_stderr' => $parent_stderr_socket,
- 'child_stdin' => $opts->{'child_stdin'},
- });
- }
- else {
- print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
- $child_exit_code = 1;
- }
+ my $child_exit_code = open3_run($cmd, {
+ 'parent_info' => $parent_info_socket,
+ 'parent_stdout' => $parent_stdout_socket,
+ 'parent_stderr' => $parent_stderr_socket,
+ 'child_stdin' => $opts->{'child_stdin'},
+ });
close($parent_stdout_socket);
close($parent_stderr_socket);
close($parent_info_socket);
- if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
- $opts->{'child_END'}->();
- }
-
- $| = 1;
- POSIX::_exit $child_exit_code;
+ exit $child_exit_code;
}
}
@@ -1215,35 +830,30 @@ sub run {
my $self = bless {}, __PACKAGE__;
my %hash = @_;
-
+
### if the user didn't provide a buffer, we'll store it here.
my $def_buf = '';
-
+
my($verbose,$cmd,$buffer,$timeout);
my $tmpl = {
verbose => { default => $VERBOSE, store => \$verbose },
buffer => { default => \$def_buf, store => \$buffer },
command => { required => 1, store => \$cmd,
- allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
+ allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
},
- timeout => { default => 0, store => \$timeout },
+ timeout => { default => 0, store => \$timeout },
};
-
+
unless( check( $tmpl, \%hash, $VERBOSE ) ) {
Carp::carp( loc( "Could not validate input: %1",
Params::Check->last_error ) );
return;
- };
+ };
$cmd = _quote_args_vms( $cmd ) if IS_VMS;
### strip any empty elements from $cmd if present
- if ( $ALLOW_NULL_ARGS ) {
- $cmd = [ grep { defined } @$cmd ] if ref $cmd;
- }
- else {
- $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
- }
+ $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
@@ -1253,7 +863,7 @@ sub run {
### XXX this is now being ignored. in the future, we could add diagnostic
### messages based on this logic
#my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
-
+
### buffers that are to be captured
my( @buffer, @buff_err, @buff_out );
@@ -1261,81 +871,78 @@ sub run {
my $_out_handler = sub {
my $buf = shift;
return unless defined $buf;
-
+
print STDOUT $buf if $verbose;
push @buffer, $buf;
push @buff_out, $buf;
};
-
+
### capture STDERR
my $_err_handler = sub {
my $buf = shift;
return unless defined $buf;
-
+
print STDERR $buf if $verbose;
push @buffer, $buf;
push @buff_err, $buf;
};
-
+
### flag to indicate we have a buffer captured
my $have_buffer = $self->can_capture_buffer ? 1 : 0;
-
+
### flag indicating if the subcall went ok
my $ok;
-
- ### don't look at previous errors:
- local $?;
+
+ ### dont look at previous errors:
+ local $?;
local $@;
local $!;
### we might be having a timeout set
- eval {
- local $SIG{ALRM} = sub { die bless sub {
- ALARM_CLASS .
+ eval {
+ local $SIG{ALRM} = sub { die bless sub {
+ ALARM_CLASS .
qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
}, ALARM_CLASS } if $timeout;
alarm $timeout || 0;
-
+
### IPC::Run is first choice if $USE_IPC_RUN is set.
- if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
+ if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
### ipc::run handlers needs the command as a string or an array ref
-
+
$self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
if $DEBUG;
-
+
$ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
-
+
### since IPC::Open3 works on all platforms, and just fails on
### win32 for capturing buffers, do that ideally
} elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
-
+
$self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
if $DEBUG;
-
+
### in case there are pipes in there;
- ### IPC::Open3 will call exec and exec will do the right thing
-
- my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run';
-
- $ok = $self->$method(
- $cmd, $_out_handler, $_err_handler, $verbose
+ ### IPC::Open3 will call exec and exec will do the right thing
+ $ok = $self->_open3_run(
+ $cmd, $_out_handler, $_err_handler, $verbose
);
-
+
### if we are allowed to run verbose, just dispatch the system command
} else {
$self->_debug( "# Using system(). Have buffer: $have_buffer" )
if $DEBUG;
$ok = $self->_system_run( $cmd, $verbose );
}
-
+
alarm 0;
};
-
+
### restore STDIN after duping, or STDIN will be closed for
- ### this current perl process!
+ ### this current perl process!
$self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
-
+
my $err;
unless( $ok ) {
### alarm happened
@@ -1347,10 +954,10 @@ sub run {
$err = $self->error;
}
}
-
+
### fill the buffer;
$$buffer = join '', @buffer if @buffer;
-
+
### return a list of flags and buffers (if available) in list
### context, or just a simple 'ok' in scalar
return wantarray
@@ -1358,90 +965,11 @@ sub run {
? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
: ($ok, $err )
: $ok
-
-
-}
-
-sub _open3_run_win32 {
- my $self = shift;
- my $cmd = shift;
- my $outhand = shift;
- my $errhand = shift;
-
- require Socket;
-
- my $pipe = sub {
- socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC)
- or return undef;
- shutdown($_[0], 1); # No more writing for reader
- shutdown($_[1], 0); # No more reading for writer
- return 1;
- };
-
- my $open3 = sub {
- local (*TO_CHLD_R, *TO_CHLD_W);
- local (*FR_CHLD_R, *FR_CHLD_W);
- local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);
-
- $pipe->(*TO_CHLD_R, *TO_CHLD_W ) or die $^E;
- $pipe->(*FR_CHLD_R, *FR_CHLD_W ) or die $^E;
- $pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;
-
- my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);
-
- return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
- };
-
- $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
- $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
-
- my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
- $open3->( ( ref $cmd ? @$cmd : $cmd ) );
-
- my $in_sel = IO::Select->new();
- my $out_sel = IO::Select->new();
-
- my %objs;
-
- $objs{ fileno( $fr_chld ) } = $outhand;
- $objs{ fileno( $fr_chld_err ) } = $errhand;
- $in_sel->add( $fr_chld );
- $in_sel->add( $fr_chld_err );
-
- close($to_chld);
-
- while ($in_sel->count() + $out_sel->count()) {
- my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
-
- for my $fh (@$ins) {
- my $obj = $objs{ fileno($fh) };
- my $buf;
- my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
- if (!$bytes_read) {
- $in_sel->remove($fh);
- }
- else {
- $obj->( "$buf" );
- }
- }
-
- for my $fh (@$outs) {
- }
- }
-
- waitpid($pid, 0);
-
- ### some error occurred
- if( $? ) {
- $self->error( $self->_pp_child_error( $cmd, $? ) );
- $self->ok( 0 );
- return;
- } else {
- return $self->ok( 1 );
- }
+
+
}
-sub _open3_run {
+sub _open3_run {
my $self = shift;
my $cmd = shift;
my $_out_handler = shift;
@@ -1455,7 +983,7 @@ sub _open3_run {
### define them beforehand, so we always have defined FH's
### to read from.
- use Symbol;
+ use Symbol;
my $kidout = Symbol::gensym();
my $kiderror = Symbol::gensym();
@@ -1465,20 +993,20 @@ sub _open3_run {
### to revive the FH afterwards, as IPC::Open3 closes it.
### We'll do the same for STDOUT and STDERR. It works without
### duping them on non-unix derivatives, but not on win32.
- my @fds_to_dup = ( IS_WIN32 && !$verbose
- ? qw[STDIN STDOUT STDERR]
+ my @fds_to_dup = ( IS_WIN32 && !$verbose
+ ? qw[STDIN STDOUT STDERR]
: qw[STDIN]
);
$self->_fds( \@fds_to_dup );
$self->__dup_fds( @fds_to_dup );
-
+
### pipes have to come in a quoted string, and that clashes with
### whitespace. This sub fixes up such commands so they run properly
$cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
-
- ### don't stringify @$cmd, so spaces in filenames/paths are
+
+ ### dont stringify @$cmd, so spaces in filenames/paths are
### treated properly
- my $pid = eval {
+ my $pid = eval {
IPC::Open3::open3(
'<&STDIN',
(IS_WIN32 ? '>&STDOUT' : $kidout),
@@ -1486,8 +1014,8 @@ sub _open3_run {
( ref $cmd ? @$cmd : $cmd ),
);
};
-
- ### open3 error occurred
+
+ ### open3 error occurred
if( $@ and $@ =~ /^open3:/ ) {
$self->ok( 0 );
$self->error( $@ );
@@ -1498,16 +1026,16 @@ sub _open3_run {
### we never get the input.. so jump through
### some hoops to do it :(
my $selector = IO::Select->new(
- (IS_WIN32 ? \*STDERR : $kiderror),
- \*STDIN,
- (IS_WIN32 ? \*STDOUT : $kidout)
- );
+ (IS_WIN32 ? \*STDERR : $kiderror),
+ \*STDIN,
+ (IS_WIN32 ? \*STDOUT : $kidout)
+ );
STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
$kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
$kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
- ### add an explicit break statement
+ ### add an epxlicit break statement
### code courtesy of theorbtwo from #london.pm
my $stdout_done = 0;
my $stderr_done = 0;
@@ -1515,10 +1043,10 @@ sub _open3_run {
for my $h ( @ready ) {
my $buf;
-
+
### $len is the amount of bytes read
my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
-
+
### see perldoc -f sysread: it returns undef on error,
### so bail out.
if( not defined $len ) {
@@ -1546,10 +1074,10 @@ sub _open3_run {
### this current perl process!
### done in the parent call now
# $self->__reopen_fds( @fds_to_dup );
-
+
### some error occurred
if( $? ) {
- $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
$self->ok( 0 );
return;
} else {
@@ -1557,18 +1085,18 @@ sub _open3_run {
}
}
-### Text::ParseWords::shellwords() uses unix semantics. that will break
+### text::parsewords::shellwordss() uses unix semantics. that will break
### on win32
-{ my $parse_sub = IS_WIN32
+{ my $parse_sub = IS_WIN32
? __PACKAGE__->can('_split_like_shell_win32')
: Text::ParseWords->can('shellwords');
- sub _ipc_run {
+ sub _ipc_run {
my $self = shift;
my $cmd = shift;
my $_out_handler = shift;
my $_err_handler = shift;
-
+
STDOUT->autoflush(1); STDERR->autoflush(1);
### a command like:
@@ -1588,10 +1116,10 @@ sub _open3_run {
# ['/usr/bin/tar', '-tf -']
# ]
-
- my @command;
+
+ my @command;
my $special_chars;
-
+
my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
if( ref $cmd ) {
my $aref = [];
@@ -1615,27 +1143,27 @@ sub _open3_run {
} split( /\s*$re\s*/, $cmd );
}
- ### if there's a pipe in the command, *STDIN needs to
+ ### if there's a pipe in the command, *STDIN needs to
### be inserted *BEFORE* the pipe, to work on win32
### this also works on *nix, so we should do it when possible
### this should *also* work on multiple pipes in the command
### if there's no pipe in the command, append STDIN to the back
### of the command instead.
### XXX seems IPC::Run works it out for itself if you just
- ### don't pass STDIN at all.
+ ### dont pass STDIN at all.
# if( $special_chars and $special_chars =~ /\|/ ) {
# ### only add STDIN the first time..
# my $i;
- # @command = map { ($_ eq '|' && not $i++)
- # ? ( \*STDIN, $_ )
- # : $_
- # } @command;
+ # @command = map { ($_ eq '|' && not $i++)
+ # ? ( \*STDIN, $_ )
+ # : $_
+ # } @command;
# } else {
# push @command, \*STDIN;
# }
-
+
# \*STDIN is already included in the @command, see a few lines up
- my $ok = eval { IPC::Run::run( @command,
+ my $ok = eval { IPC::Run::run( @command,
fileno(STDOUT).'>',
$_out_handler,
fileno(STDERR).'>',
@@ -1652,11 +1180,11 @@ sub _open3_run {
$self->ok( 0 );
### if the eval fails due to an exception, deal with it
- ### unless it's an alarm
- if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
+ ### unless it's an alarm
+ if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
$self->error( $@ );
- ### if it *is* an alarm, propagate
+ ### if it *is* an alarm, propagate
} elsif( $@ ) {
die $@;
@@ -1664,13 +1192,13 @@ sub _open3_run {
} else {
$self->error( $self->_pp_child_error( $cmd, $? ) );
}
-
+
return;
}
}
}
-sub _system_run {
+sub _system_run {
my $self = shift;
my $cmd = shift;
my $verbose = shift || 0;
@@ -1706,15 +1234,15 @@ sub _system_run {
### command has a special char in it
if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
-
+
### since we have special chars, we have to quote white space
### this *may* conflict with the parsing :(
my $fixed;
my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
-
+
$self->_debug( "# Quoted $fixed arguments containing whitespace" )
if $DEBUG && $fixed;
-
+
### stringify it, so the special char isn't escaped as argument
### to the program
$cmd = join ' ', @cmd;
@@ -1771,20 +1299,20 @@ sub _split_like_shell_win32 {
# into words. The algorithm below was bashed out by Randy and Ken
# (mostly Randy), and there are a lot of regression tests, so we
# should feel free to adjust if desired.
-
+
local $_ = shift;
-
+
my @argv;
return @argv unless defined() && length();
-
+
my $arg = '';
my( $i, $quote_mode ) = ( 0, 0 );
-
+
while ( $i < length() ) {
-
+
my $ch = substr( $_, $i , 1 );
my $next_ch = substr( $_, $i+1, 1 );
-
+
if ( $ch eq '\\' && $next_ch eq '"' ) {
$arg .= '"';
$i++;
@@ -1805,16 +1333,16 @@ sub _split_like_shell_win32 {
} elsif ( $ch eq '"' ) {
$quote_mode = !$quote_mode;
} elsif ( $ch eq ' ' && !$quote_mode ) {
- push( @argv, $arg ) if defined( $arg ) && length( $arg );
+ push( @argv, $arg ) if $arg;
$arg = '';
++$i while substr( $_, $i + 1, 1 ) eq ' ';
} else {
$arg .= $ch;
}
-
+
$i++;
}
-
+
push( @argv, $arg ) if defined( $arg ) && length( $arg );
return @argv;
}
@@ -1840,15 +1368,15 @@ sub _split_like_shell_win32 {
for my $name ( @fds ) {
my($redir, $fh, $glob) = @{$Map{$name}} or (
Carp::carp(loc("No such FD: '%1'", $name)), next );
-
- ### MUST use the 2-arg version of open for dup'ing for
- ### 5.6.x compatibility. 5.8.x can use 3-arg open
- ### see perldoc5.6.2 -f open for details
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
open $glob, $redir . fileno($fh) or (
Carp::carp(loc("Could not dup '$name': %1", $!)),
return
- );
-
+ );
+
### we should re-open this filehandle right now, not
### just dup it
### Use 2-arg version of open, as 5.5.x doesn't support
@@ -1860,11 +1388,11 @@ sub _split_like_shell_win32 {
);
}
}
-
+
return 1;
}
- ### reopens FDs from the cache
+ ### reopens FDs from the cache
sub __reopen_fds {
my $self = shift;
my @fds = @_;
@@ -1875,30 +1403,30 @@ sub _split_like_shell_win32 {
my($redir, $fh, $glob) = @{$Map{$name}} or (
Carp::carp(loc("No such FD: '%1'", $name)), next );
- ### MUST use the 2-arg version of open for dup'ing for
- ### 5.6.x compatibility. 5.8.x can use 3-arg open
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
### see perldoc5.6.2 -f open for details
open( $fh, $redir . fileno($glob) ) or (
Carp::carp(loc("Could not restore '$name': %1", $!)),
return
- );
-
+ );
+
### close this FD, we're not using it anymore
- close $glob;
- }
- return 1;
-
+ close $glob;
+ }
+ return 1;
+
}
-}
+}
sub _debug {
my $self = shift;
my $msg = shift or return;
my $level = shift || 0;
-
+
local $Carp::CarpLevel += $level;
Carp::carp($msg);
-
+
return 1;
}
@@ -1907,8 +1435,8 @@ sub _pp_child_error {
my $cmd = shift or return;
my $ce = shift or return;
my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
-
-
+
+
my $str;
if( $ce == -1 ) {
### Include $! in the error message, so that the user can
@@ -1916,18 +1444,18 @@ sub _pp_child_error {
### versus 'Cannot fork' or whatever the cause was.
$str = "Failed to execute '$pp_cmd': $!";
- } elsif ( $ce & 127 ) {
+ } elsif ( $ce & 127 ) {
### some signal
- $str = loc( "'%1' died with signal %2, %3 coredump",
+ $str = loc( "'%1' died with signal %d, %s coredump\n",
$pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
} else {
### Otherwise, the command run but gave error status.
$str = "'$pp_cmd' exited with value " . ($ce >> 8);
}
-
+
$self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
-
+
return $str;
}
@@ -1937,7 +1465,7 @@ sub _pp_child_error {
Returns the character used for quoting strings on this platform. This is
usually a C<'> (single quote) on most systems, but some systems use different
-quotes. For example, C<Win32> uses C<"> (double quote).
+quotes. For example, C<Win32> uses C<"> (double quote).
You can use it as follows:
@@ -1945,7 +1473,7 @@ You can use it as follows:
my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
This makes sure that C<foo bar> is treated as a string, rather than two
-separate arguments to the C<echo> function.
+seperate arguments to the C<echo> function.
__END__
@@ -1958,29 +1486,28 @@ C<run> will try to execute your command using the following logic:
=item *
If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
-is set to true (See the L<"Global Variables"> section) use that to execute
-the command. You will have the full output available in buffers, interactive commands
-are sure to work and you are guaranteed to have your verbosity
+is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
+the command. You will have the full output available in buffers, interactive commands are sure to work and you are guaranteed to have your verbosity
settings honored cleanly.
=item *
-Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
-(See the L<"Global Variables"> section), try to execute the command using
-L<IPC::Open3>. Buffers will be available on all platforms,
+Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
+(See the C<GLOBAL VARIABLES> Section), try to execute the command using
+C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
interactive commands will still execute cleanly, and also your verbosity
settings will be adhered to nicely;
=item *
-Otherwise, if you have the C<verbose> argument set to true, we fall back
-to a simple C<system()> call. We cannot capture any buffers, but
+Otherwise, if you have the verbose argument set to true, we fall back
+to a simple system() call. We cannot capture any buffers, but
interactive commands will still work.
=item *
Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
-C<system()> call with your command and then re-open STDERR and STDOUT.
+system() call with your command and then re-open STDERR and STDOUT.
This is the method of last resort and will still allow you to execute
your commands cleanly. However, no buffers will be available.
@@ -1994,12 +1521,12 @@ global variables:
=head2 $IPC::Cmd::VERBOSE
This controls whether IPC::Cmd will print any output from the
-commands to the screen or not. The default is 0.
+commands to the screen or not. The default is 0;
=head2 $IPC::Cmd::USE_IPC_RUN
This variable controls whether IPC::Cmd will try to use L<IPC::Run>
-when available and suitable.
+when available and suitable. Defaults to true if you are on C<Win32>.
=head2 $IPC::Cmd::USE_IPC_OPEN3
@@ -2008,26 +1535,11 @@ when available and suitable. Defaults to true.
=head2 $IPC::Cmd::WARN
-This variable controls whether run-time warnings should be issued, like
+This variable controls whether run time warnings should be issued, like
the failure to load an C<IPC::*> module you explicitly requested.
Defaults to true. Turn this off at your own risk.
-=head2 $IPC::Cmd::INSTANCES
-
-This variable controls whether C<can_run> will return all instances of
-the binary it finds in the C<PATH> when called in a list context.
-
-Defaults to false, set to true to enable the described behaviour.
-
-=head2 $IPC::Cmd::ALLOW_NULL_ARGS
-
-This variable controls whether C<run> will remove any empty/null arguments
-it finds in command arguments.
-
-Defaults to false, so it will remove null arguments. Set to true to allow
-them.
-
=head1 Caveats
=over 4
@@ -2037,28 +1549,28 @@ them.
When using C<IPC::Open3> or C<system>, if you provide a string as the
C<command> argument, it is assumed to be appropriately escaped. You can
use the C<QUOTE> constant to use as a portable quote character (see above).
-However, if you provide an array reference, special rules apply:
+However, if you provide and C<Array Reference>, special rules apply:
-If your command contains B<special characters> (< > | &), it will
+If your command contains C<Special Characters> (< > | &), it will
be internally stringified before executing the command, to avoid that these
special characters are escaped and passed as arguments instead of retaining
their special meaning.
-However, if the command contained arguments that contained whitespace,
-stringifying the command would lose the significance of the whitespace.
-Therefore, C<IPC::Cmd> will quote any arguments containing whitespace in your
+However, if the command contained arguments that contained whitespace,
+stringifying the command would loose the significance of the whitespace.
+Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
command if the command is passed as an arrayref and contains special characters.
=item Whitespace and IPC::Run
-When using C<IPC::Run>, if you provide a string as the C<command> argument,
-the string will be split on whitespace to determine the individual elements
+When using C<IPC::Run>, if you provide a string as the C<command> argument,
+the string will be split on whitespace to determine the individual elements
of your command. Although this will usually just Do What You Mean, it may
break if you have files or commands with whitespace in them.
If you do not wish this to happen, you should provide an array
reference, where all parts of your command are already separated out.
-Note however, if there are extra or spurious whitespaces in these parts,
+Note however, if there's extra or spurious whitespace in these parts,
the parser or underlying code may not interpret it correctly, and
cause an error.
@@ -2085,39 +1597,36 @@ Since this will lead to issues as described above.
=item IO Redirect
Currently it is too complicated to parse your command for IO
-redirections. For capturing STDOUT or STDERR there is a work around
+Redirections. For capturing STDOUT or STDERR there is a work around
however, since you can just inspect your buffers for the contents.
=item Interleaving STDOUT/STDERR
Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
-bursts of output from a program, e.g. this sample,
+bursts of output from a program, ie this sample:
for ( 1..4 ) {
$_ % 2 ? print STDOUT $_ : print STDERR $_;
}
-IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
-the output looks like '13' on STDOUT and '24' on STDERR, instead of
+IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
+the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
- 1
- 2
- 3
- 4
+It should have been 1, 2, 3, 4.
This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
-STDOUT and STDERR.
+STDOUT and STDERR
=back
=head1 See Also
-L<IPC::Run>, L<IPC::Open3>
+C<IPC::Run>, C<IPC::Open3>
=head1 ACKNOWLEDGEMENTS
Thanks to James Mastros and Martijn van der Streek for their
-help in getting L<IPC::Open3> to behave nicely.
+help in getting IPC::Open3 to behave nicely.
Thanks to Petya Kohts for the C<run_forked> code.
@@ -2127,12 +1636,11 @@ Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
=head1 AUTHOR
-Original author: Jos Boumans E<lt>kane@cpan.orgE<gt>.
-Current maintainer: Chris Williams E<lt>bingos@cpan.orgE<gt>.
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
=head1 COPYRIGHT
-This library is free software; you may redistribute and/or modify it
+This library is free software; you may redistribute and/or modify it
under the same terms as Perl itself.
=cut
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/AnyDBM_File.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/AnyDBM_File.pm
index cf5f7f5bc21..91f960962f9 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/AnyDBM_File.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/AnyDBM_File.pm
@@ -11,7 +11,7 @@ See L<Memoize>.
=cut
use vars qw(@ISA $VERSION);
-$VERSION = '1.03';
+$VERSION = 0.65;
@ISA = qw(DB_File GDBM_File Memoize::NDBM_File Memoize::SDBM_File ODBM_File) unless @ISA;
my $verbose = 1;
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/Expire.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/Expire.pm
index 9b3b94444c1..97e1aa44208 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/Expire.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/Expire.pm
@@ -3,7 +3,7 @@ package Memoize::Expire;
# require 5.00556;
use Carp;
$DEBUG = 0;
-$VERSION = '1.03';
+$VERSION = '1.00';
# This package will implement expiration by prepending a fixed-length header
# to the font of the cached data. The format of the header will be:
@@ -311,11 +311,6 @@ the underlying cache so that the user can specify that the cache is
also persistent or that it has some other interesting semantics. The
example above demonstrates how to do this, as does C<Memoize::Expire>.
-Another sample module, L<Memoize::Saves>, is available in a separate
-distribution on CPAN. It implements a policy that allows you to
-specify that certain function values would always be looked up afresh.
-See the documentation for details.
-
=head1 ALTERNATIVES
Brent Powers has a C<Memoize::ExpireLRU> module that was designed to
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireFile.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireFile.pm
index 06b72f8ef2a..e52c09a3bf3 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireFile.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireFile.pm
@@ -10,7 +10,7 @@ See L<Memoize::Expire>.
=cut
-$VERSION = '1.03';
+$VERSION = 1.01;
use Carp;
my $Zero = pack("N", 0);
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireTest.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireTest.pm
index 7f7dd28af6f..729f6b98506 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireTest.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/ExpireTest.pm
@@ -18,7 +18,7 @@ to mjd-perl-memoize+@plover.com.
=cut
-$VERSION = '1.03';
+$VERSION = 0.65;
my %cache;
sub TIEHASH {
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/NDBM_File.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/NDBM_File.pm
index ff934c656bc..96eabfbb7c8 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/NDBM_File.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/NDBM_File.pm
@@ -12,7 +12,7 @@ See L<Memoize>.
use NDBM_File;
@ISA = qw(NDBM_File);
-$VERSION = '1.03';
+$VERSION = 0.65;
$Verbose = 0;
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/SDBM_File.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/SDBM_File.pm
index 7cfaa4afb98..f66273f2747 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/SDBM_File.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/SDBM_File.pm
@@ -12,7 +12,7 @@ See L<Memoize>.
use SDBM_File;
@ISA = qw(SDBM_File);
-$VERSION = '1.03';
+$VERSION = 0.65;
$Verbose = 0;
diff --git a/gnu/usr.bin/perl/cpan/Memoize/Memoize/Storable.pm b/gnu/usr.bin/perl/cpan/Memoize/Memoize/Storable.pm
index 13147972972..4c29dd7eb8f 100644
--- a/gnu/usr.bin/perl/cpan/Memoize/Memoize/Storable.pm
+++ b/gnu/usr.bin/perl/cpan/Memoize/Memoize/Storable.pm
@@ -11,7 +11,7 @@ See L<Memoize>.
=cut
use Storable ();
-$VERSION = '1.03';
+$VERSION = 0.65;
$Verbose = 0;
sub TIEHASH {
diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm b/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm
index 25164af320c..002e6e4f16e 100644
--- a/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm
+++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm
@@ -3,15 +3,16 @@ use strict;
use warnings;
use warnings::register;
use Carp;
-use Exporter qw< import >;
+use Exporter ();
+use Fcntl qw(O_WRONLY);
use File::Basename;
-use POSIX qw< strftime setlocale LC_TIME >;
-use Socket qw< :all >;
+use POSIX qw(strftime setlocale LC_TIME);
+use Socket ':all';
require 5.005;
-
{ no strict 'vars';
- $VERSION = '0.33';
+ $VERSION = '0.27';
+ @ISA = qw(Exporter);
%EXPORT_TAGS = (
standard => [qw(openlog syslog closelog setlogmask)],
@@ -85,23 +86,20 @@ sub silent_eval (&);
# Global variables
#
use vars qw($facility);
-my $connected = 0; # flag to indicate if we're connected or not
+my $connected = 0; # flag to indicate if we're connected or not
my $syslog_send; # coderef of the function used to send messages
-my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
-my $syslog_xobj = undef; # if defined, holds the external object used to send messages
-my $transmit_ok = 0; # flag to indicate if the last message was transmitted
-my $sock_port = undef; # socket port
-my $sock_timeout = 0; # socket timeout, see below
-my $current_proto = undef; # current mechanism used to transmit messages
-my $ident = ''; # identifiant prepended to each message
-$facility = ''; # current facility
-my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask
+my $syslog_path = undef; # syslog path for "stream" and "unix" mechanisms
+my $syslog_xobj = undef; # if defined, holds the external object used to send messages
+my $transmit_ok = 0; # flag to indicate if the last message was transmited
+my $sock_timeout = 0; # socket timeout, see below
+my $current_proto = undef; # current mechanism used to transmit messages
+my $ident = ''; # identifiant prepended to each message
+$facility = ''; # current facility
+my $maskpri = LOG_UPTO(&LOG_DEBUG); # current log mask
my %options = (
ndelay => 0,
- noeol => 0,
nofatal => 0,
- nonul => 0,
nowait => 0,
perror => 0,
pid => 0,
@@ -110,7 +108,7 @@ my %options = (
# Default is now to first use the native mechanism, so Perl programs
# behave like other normal Unix programs, then try other mechanisms.
my @connectMethods = qw(native tcp udp unix pipe stream console);
-if ($^O eq "freebsd" or $^O eq "linux") {
+if ($^O =~ /^(freebsd|linux)$/) {
@connectMethods = grep { $_ ne 'udp' } @connectMethods;
}
@@ -119,9 +117,12 @@ if ($^O eq "freebsd" or $^O eq "linux") {
EVENTLOG: {
my $is_Win32 = $^O =~ /Win32/i;
- if (can_load("Sys::Syslog::Win32", $is_Win32)) {
+ if (can_load("Sys::Syslog::Win32")) {
unshift @connectMethods, 'eventlog';
}
+ elsif ($is_Win32) {
+ warn $@;
+ }
}
my @defaultMethods = @connectMethods;
@@ -137,21 +138,7 @@ my @fallbackMethods = ();
# happy, the timeout is now zero by default on all systems
# except on OSX where it is set to 250 msec, and can be set
# with the infamous setlogsock() function.
-#
-# Update 2011-08: this issue is also been seen on multiprocessor
-# Debian GNU/kFreeBSD systems. See http://bugs.debian.org/627821
-# and https://rt.cpan.org/Ticket/Display.html?id=69997
-# Also, lowering the delay to 1 ms, which should be enough.
-
-$sock_timeout = 0.001 if $^O =~ /darwin|gnukfreebsd/;
-
-
-# Perl 5.6.0's warnings.pm doesn't have warnings::warnif()
-if (not defined &warnings::warnif) {
- *warnings::warnif = sub {
- goto &warnings::warn if warnings::enabled(__PACKAGE__)
- }
-}
+$sock_timeout = 0.25 if $^O =~ /darwin/;
# coderef for a nicer handling of errors
my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
@@ -190,11 +177,8 @@ sub openlog {
}
sub closelog {
- disconnect_log() if $connected;
- $options{$_} = 0 for keys %options;
- $facility = $ident = "";
- $connected = 0;
- return 1
+ $facility = $ident = '';
+ disconnect_log();
}
sub setlogmask {
@@ -202,152 +186,125 @@ sub setlogmask {
$maskpri = shift unless $_[0] == 0;
$oldmask;
}
+
+sub setlogsock {
+ my ($setsock, $setpath, $settime) = @_;
+ # check arguments
+ my $diag_invalid_arg
+ = "Invalid argument passed to setlogsock; must be 'stream', 'pipe', "
+ . "'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'";
+ croak $diag_invalid_arg unless defined $setsock;
+ croak "Invalid number of arguments" unless @_ >= 1 and @_ <= 3;
-my %mechanism = (
- console => {
- check => sub { 1 },
- },
- eventlog => {
- check => sub { return can_load("Win32::EventLog") },
- err_msg => "no Win32 API available",
- },
- inet => {
- check => sub { 1 },
- },
- native => {
- check => sub { 1 },
- },
- pipe => {
- check => sub {
- ($syslog_path) = grep { defined && length && -p && -w _ }
- $syslog_path, &_PATH_LOG, "/dev/log";
- return $syslog_path ? 1 : 0
- },
- err_msg => "path not available",
- },
- stream => {
- check => sub {
- if (not defined $syslog_path) {
- my @try = qw(/dev/log /dev/conslog);
- unshift @try, &_PATH_LOG if length &_PATH_LOG;
- ($syslog_path) = grep { -w } @try;
- }
- return defined $syslog_path && -w $syslog_path
- },
- err_msg => "could not find any writable device",
- },
- tcp => {
- check => sub {
- return 1 if defined $sock_port;
-
- if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
- $host = $syslog_path;
- return 1
- }
- else {
- return
- }
- },
- err_msg => "TCP service unavailable",
- },
- udp => {
- check => sub {
- return 1 if defined $sock_port;
-
- if (getservbyname('syslog', 'udp')) {
- $host = $syslog_path;
- return 1
+ $syslog_path = $setpath if defined $setpath;
+ $sock_timeout = $settime if defined $settime;
+
+ disconnect_log() if $connected;
+ $transmit_ok = 0;
+ @fallbackMethods = ();
+ @connectMethods = @defaultMethods;
+
+ if (ref $setsock eq 'ARRAY') {
+ @connectMethods = @$setsock;
+
+ } elsif (lc $setsock eq 'stream') {
+ if (not defined $syslog_path) {
+ my @try = qw(/dev/log /dev/conslog);
+
+ if (length &_PATH_LOG) { # Undefined _PATH_LOG is "".
+ unshift @try, &_PATH_LOG;
}
- else {
- return
+
+ for my $try (@try) {
+ if (-w $try) {
+ $syslog_path = $try;
+ last;
+ }
+ }
+
+ if (not defined $syslog_path) {
+ warnings::warnif "stream passed to setlogsock, but could not find any device";
+ return undef
}
- },
- err_msg => "UDP service unavailable",
- },
- unix => {
- check => sub {
- my @try = ($syslog_path, &_PATH_LOG);
- ($syslog_path) = grep { defined && length && -w } @try;
- return defined $syslog_path && -w $syslog_path
- },
- err_msg => "path not available",
- },
-);
-
-sub setlogsock {
- my %opt;
-
- # handle arguments
- # - old API: setlogsock($sock_type, $sock_path, $sock_timeout)
- # - new API: setlogsock(\%options)
- croak "setlogsock(): Invalid number of arguments"
- unless @_ >= 1 and @_ <= 3;
-
- if (my $ref = ref $_[0]) {
- if ($ref eq "HASH") {
- %opt = %{ $_[0] };
- croak "setlogsock(): No argument given" unless keys %opt;
}
- elsif ($ref eq "ARRAY") {
- @opt{qw< type path timeout >} = @_;
+
+ if (not -w $syslog_path) {
+ warnings::warnif "stream passed to setlogsock, but $syslog_path is not writable";
+ return undef;
+ } else {
+ @connectMethods = qw(stream);
+ }
+
+ } elsif (lc $setsock eq 'unix') {
+ if (length _PATH_LOG() || (defined $syslog_path && -w $syslog_path)) {
+ $syslog_path = _PATH_LOG() unless defined $syslog_path;
+ @connectMethods = qw(unix);
+ } else {
+ warnings::warnif 'unix passed to setlogsock, but path not available';
+ return undef;
}
- else {
- croak "setlogsock(): Unexpected \L$ref\E reference"
+
+ } elsif (lc $setsock eq 'pipe') {
+ for my $path ($syslog_path, &_PATH_LOG, "/dev/log") {
+ next unless defined $path and length $path and -p $path and -w _;
+ $syslog_path = $path;
+ last
}
- }
- else {
- @opt{qw< type path timeout >} = @_;
- }
- # check socket type, remove invalid ones
- my $diag_invalid_type = "setlogsock(): Invalid type%s; must be one of "
- . join ", ", map { "'$_'" } sort keys %mechanism;
- croak sprintf $diag_invalid_type, "" unless defined $opt{type};
- my @sock_types = ref $opt{type} eq "ARRAY" ? @{$opt{type}} : ($opt{type});
- my @tmp;
-
- for my $sock_type (@sock_types) {
- carp sprintf $diag_invalid_type, " '$sock_type'" and next
- unless exists $mechanism{$sock_type};
- push @tmp, "tcp", "udp" and next if $sock_type eq "inet";
- push @tmp, $sock_type;
- }
+ if (not $syslog_path) {
+ warnings::warnif "pipe passed to setlogsock, but path not available";
+ return undef
+ }
- @sock_types = @tmp;
+ @connectMethods = qw(pipe);
- # set global options
- $syslog_path = $opt{path} if defined $opt{path};
- $host = $opt{host} if defined $opt{host};
- $sock_timeout = $opt{timeout} if defined $opt{timeout};
- $sock_port = $opt{port} if defined $opt{port};
+ } elsif (lc $setsock eq 'native') {
+ @connectMethods = qw(native);
- disconnect_log() if $connected;
- $transmit_ok = 0;
- @fallbackMethods = ();
- @connectMethods = ();
- my $found = 0;
-
- # check each given mechanism and test if it can be used on the current system
- for my $sock_type (@sock_types) {
- if ( $mechanism{$sock_type}{check}->() ) {
- push @connectMethods, $sock_type;
- $found = 1;
+ } elsif (lc $setsock eq 'eventlog') {
+ if (can_load("Win32::EventLog")) {
+ @connectMethods = qw(eventlog);
+ } else {
+ warnings::warnif "eventlog passed to setlogsock, but no Win32 API available";
+ $@ = "";
+ return undef;
}
- else {
- warnings::warnif("setlogsock(): type='$sock_type': "
- . $mechanism{$sock_type}{err_msg});
- }
- }
- # if no mechanism worked from the given ones, use the default ones
- @connectMethods = @defaultMethods unless @connectMethods;
+ } elsif (lc $setsock eq 'tcp') {
+ if (getservbyname('syslog', 'tcp') || getservbyname('syslogng', 'tcp')) {
+ @connectMethods = qw(tcp);
+ $host = $syslog_path;
+ } else {
+ warnings::warnif "tcp passed to setlogsock, but tcp service unavailable";
+ return undef;
+ }
+
+ } elsif (lc $setsock eq 'udp') {
+ if (getservbyname('syslog', 'udp')) {
+ @connectMethods = qw(udp);
+ $host = $syslog_path;
+ } else {
+ warnings::warnif "udp passed to setlogsock, but udp service unavailable";
+ return undef;
+ }
+
+ } elsif (lc $setsock eq 'inet') {
+ @connectMethods = ( 'tcp', 'udp' );
+
+ } elsif (lc $setsock eq 'console') {
+ @connectMethods = qw(console);
+
+ } else {
+ croak $diag_invalid_arg
+ }
- return $found;
+ return 1;
}
sub syslog {
- my ($priority, $mask, @args) = @_;
+ my $priority = shift;
+ my $mask = shift;
my ($message, $buf);
my (@words, $num, $numpri, $numfac, $sum);
my $failed = undef;
@@ -363,48 +320,33 @@ sub syslog {
croak "syslog: expecting argument \$priority" unless defined $priority;
croak "syslog: expecting argument \$format" unless defined $mask;
- if ($priority =~ /^\d+$/) {
- $numpri = LOG_PRI($priority);
- $numfac = LOG_FAC($priority) << 3;
- }
- elsif ($priority =~ /^\w+/) {
- # Allow "level" or "level|facility".
- @words = split /\W+/, $priority, 2;
-
- undef $numpri;
- undef $numfac;
+ croak "syslog: invalid level/facility: $priority" if $priority =~ /^-\d+$/;
+ @words = split(/\W+/, $priority, 2); # Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
- for my $word (@words) {
- next if length $word == 0;
+ for my $word (@words) {
+ next if length $word == 0;
- # Translate word to number.
- $num = xlate($word);
+ $num = xlate($word); # Translate word to number.
- if ($num < 0) {
- croak "syslog: invalid level/facility: $word"
- }
- elsif ($num <= LOG_PRIMASK() and $word ne "kern") {
- croak "syslog: too many levels given: $word"
- if defined $numpri;
- $numpri = $num;
- }
- else {
- croak "syslog: too many facilities given: $word"
- if defined $numfac;
- $facility = $word if $word =~ /^[A-Za-z]/;
- $numfac = $num;
- }
+ if ($num < 0) {
+ croak "syslog: invalid level/facility: $word"
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ croak "syslog: too many levels given: $word" if defined $numpri;
+ $numpri = $num;
+ return 0 unless LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ croak "syslog: too many facilities given: $word" if defined $numfac;
+ $facility = $word;
+ $numfac = $num;
}
- }
- else {
- croak "syslog: invalid level/facility: $priority"
}
croak "syslog: level must be given" unless defined $numpri;
- # don't log if priority is below mask level
- return 0 unless LOG_MASK($numpri) & $maskpri;
-
if (not defined $numfac) { # Facility not specified in this call.
$facility = 'user' unless $facility;
$numfac = xlate($facility);
@@ -414,13 +356,17 @@ sub syslog {
if ($mask =~ /%m/) {
# escape percent signs for sprintf()
- $error =~ s/%/%%/g if @args;
+ $error =~ s/%/%%/g if @_;
# replace %m with $error, if preceded by an even number of percent signs
$mask =~ s/(?<!%)((?:%%)*)%m/$1$error/g;
}
$mask .= "\n" unless $mask =~ /\n$/;
- $message = @args ? sprintf($mask, @args) : $mask;
+ $message = @_ ? sprintf($mask, @_) : $mask;
+
+ # See CPAN-RT#24431. Opened on Apple Radar as bug #4944407 on 2007.01.21
+ # Supposedly resolved on Leopard.
+ chomp $message if $^O =~ /darwin/;
if ($current_proto eq 'native') {
$buf = $message;
@@ -435,22 +381,15 @@ sub syslog {
$sum = $numpri + $numfac;
my $oldlocale = setlocale(LC_TIME);
setlocale(LC_TIME, 'C');
- my $timestamp = strftime "%b %d %H:%M:%S", localtime;
+ my $timestamp = strftime "%b %e %T", localtime;
setlocale(LC_TIME, $oldlocale);
-
- # construct the stream that will be transmitted
- $buf = "<$sum>$timestamp $whoami: $message";
-
- # add (or not) a newline
- $buf .= "\n" if !$options{noeol} and rindex($buf, "\n") == -1;
-
- # add (or not) a NUL character
- $buf .= "\0" if !$options{nonul};
+ $buf = "<$sum>$timestamp $whoami: $message\0";
}
# handle PERROR option
# "native" mechanism already handles it by itself
if ($options{perror} and $current_proto ne 'native') {
+ chomp $message;
my $whoami = $ident;
$whoami .= "[$$]" if $options{pid};
print STDERR "$whoami: $message\n";
@@ -497,7 +436,7 @@ sub syslog {
sub _syslog_send_console {
my ($buf) = @_;
-
+ chop($buf); # delete the NUL from the end
# The console print is a method which could block
# so we do it in a child process and always return success
# to the caller.
@@ -517,11 +456,10 @@ sub _syslog_send_console {
} else {
if (open(CONS, ">/dev/console")) {
my $ret = print CONS $buf . "\r"; # XXX: should this be \x0A ?
- POSIX::_exit($ret) if defined $pid;
+ exit $ret if defined $pid;
close CONS;
}
-
- POSIX::_exit(0) if defined $pid;
+ exit if defined $pid;
}
}
@@ -546,8 +484,8 @@ sub _syslog_send_socket {
}
sub _syslog_send_native {
- my ($buf, $numpri, $numfac) = @_;
- syslog_xs($numpri|$numfac, $buf);
+ my ($buf, $numpri) = @_;
+ syslog_xs($numpri, $buf);
return 1;
}
@@ -622,15 +560,15 @@ sub connect_log {
sub connect_tcp {
my ($errs) = @_;
- my $proto = getprotobyname('tcp');
- if (!defined $proto) {
+ my $tcp = getprotobyname('tcp');
+ if (!defined $tcp) {
push @$errs, "getprotobyname failed for tcp";
return 0;
}
- my $port = $sock_port || getservbyname('syslog', 'tcp');
- $port = getservbyname('syslogng', 'tcp') unless defined $port;
- if (!defined $port) {
+ my $syslog = getservbyname('syslog', 'tcp');
+ $syslog = getservbyname('syslogng', 'tcp') unless defined $syslog;
+ if (!defined $syslog) {
push @$errs, "getservbyname failed for syslog/tcp and syslogng/tcp";
return 0;
}
@@ -645,9 +583,9 @@ sub connect_tcp {
} else {
$addr = INADDR_LOOPBACK;
}
- $addr = sockaddr_in($port, $addr);
+ $addr = sockaddr_in($syslog, $addr);
- if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $proto)) {
+ if (!socket(SYSLOG, AF_INET, SOCK_STREAM, $tcp)) {
push @$errs, "tcp socket: $!";
return 0;
}
@@ -670,14 +608,14 @@ sub connect_tcp {
sub connect_udp {
my ($errs) = @_;
- my $proto = getprotobyname('udp');
- if (!defined $proto) {
+ my $udp = getprotobyname('udp');
+ if (!defined $udp) {
push @$errs, "getprotobyname failed for udp";
return 0;
}
- my $port = $sock_port || getservbyname('syslog', 'udp');
- if (!defined $port) {
+ my $syslog = getservbyname('syslog', 'udp');
+ if (!defined $syslog) {
push @$errs, "getservbyname failed for syslog/udp";
return 0;
}
@@ -692,9 +630,9 @@ sub connect_udp {
} else {
$addr = INADDR_LOOPBACK;
}
- $addr = sockaddr_in($port, $addr);
+ $addr = sockaddr_in($syslog, $addr);
- if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $proto)) {
+ if (!socket(SYSLOG, AF_INET, SOCK_DGRAM, $udp)) {
push @$errs, "udp socket: $!";
return 0;
}
@@ -721,21 +659,15 @@ sub connect_stream {
# might want syslog_path to be variable based on syslog.h (if only
# it were in there!)
$syslog_path = '/dev/conslog' unless defined $syslog_path;
-
if (!-w $syslog_path) {
push @$errs, "stream $syslog_path is not writable";
return 0;
}
-
- require Fcntl;
-
- if (!sysopen(SYSLOG, $syslog_path, Fcntl::O_WRONLY(), 0400)) {
+ if (!sysopen(SYSLOG, $syslog_path, O_WRONLY, 0400)) {
push @$errs, "stream can't open $syslog_path: $!";
return 0;
}
-
$syslog_send = \&_syslog_send_stream;
-
return 1;
}
@@ -858,14 +790,10 @@ sub disconnect_log {
if (defined $current_proto and $current_proto eq 'native') {
closelog_xs();
- unshift @fallbackMethods, $current_proto;
- $current_proto = undef;
return 1;
}
elsif (defined $current_proto and $current_proto eq 'eventlog') {
$syslog_xobj->Close();
- unshift @fallbackMethods, $current_proto;
- $current_proto = undef;
return 1;
}
@@ -886,11 +814,8 @@ sub silent_eval (&) {
}
sub can_load {
- my ($module, $verbose) = @_;
local($SIG{__DIE__}, $SIG{__WARN__}, $@);
- my $loaded = eval "use $module; 1";
- warn $@ if not $loaded and $verbose;
- return $loaded
+ return eval "use $_[0]; 1"
}
@@ -904,17 +829,18 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls
=head1 VERSION
-This is the documentation of version 0.33
+Version 0.27
=head1 SYNOPSIS
- use Sys::Syslog; # all except setlogsock()
- use Sys::Syslog qw(:standard :macros); # standard functions & macros
+ use Sys::Syslog; # all except setlogsock(), or:
+ use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock()
+ use Sys::Syslog qw(:standard :macros); # standard functions, plus macros
- openlog($ident, $logopt, $facility); # don't forget this
- syslog($priority, $format, @args);
- $oldmask = setlogmask($mask_priority);
- closelog();
+ openlog $ident, $logopt, $facility; # don't forget this
+ syslog $priority, $format, @args;
+ $oldmask = setlogmask $mask_priority;
+ closelog;
=head1 DESCRIPTION
@@ -923,6 +849,9 @@ C<Sys::Syslog> is an interface to the UNIX C<syslog(3)> program.
Call C<syslog()> with a string priority and a list of C<printf()> args
just like C<syslog(3)>.
+You can find a kind of FAQ in L<"THE RULES OF SYS::SYSLOG">. Please read
+it before coding, and again before asking questions.
+
=head1 EXPORTS
@@ -990,22 +919,12 @@ opened when the first message is logged).
=item *
-C<noeol> - When set to true, no end of line character (C<\n>) will be
-appended to the message. This can be useful for some buggy syslog daemons.
-
-=item *
-
C<nofatal> - When set to true, C<openlog()> and C<syslog()> will only
emit warnings instead of dying if the connection to the syslog can't
be established.
=item *
-C<nonul> - When set to true, no C<NUL> character (C<\0>) will be
-appended to the message. This can be useful for some buggy syslog daemons.
-
-=item *
-
C<nowait> - Don't wait for child processes that may have been created
while logging the message. (The GNU C library does not create a child
process, so this option has no effect on Linux.)
@@ -1013,7 +932,7 @@ process, so this option has no effect on Linux.)
=item *
C<perror> - Write the message to standard error output as well to the
-system log (added in C<Sys::Syslog> 0.22).
+system log.
=item *
@@ -1043,7 +962,7 @@ C<"$!"> (the latest error message).
C<$priority> can specify a level, or a level and a facility. Levels and
facilities can be given as strings or as macros. When using the C<eventlog>
mechanism, priorities C<DEBUG> and C<INFO> are mapped to event type
-C<informational>, C<NOTICE> and C<WARNING> to C<warning> and C<ERR> to
+C<informational>, C<NOTICE> and C<WARNIN> to C<warning> and C<ERR> to
C<EMERG> to C<error>.
If you didn't use C<openlog()> before using C<syslog()>, C<syslog()> will
@@ -1052,13 +971,11 @@ C<$format> that ends in a C<":">.
B<Examples>
- # informational level
- syslog("info", $message);
- syslog(LOG_INFO, $message);
+ syslog("info", $message); # informational level
+ syslog(LOG_INFO, $message); # informational level
- # information level, Local0 facility
- syslog("info|local0", $message);
- syslog(LOG_INFO|LOG_LOCAL0, $message);
+ syslog("info|local0", $message); # information level, Local0 facility
+ syslog(LOG_INFO|LOG_LOCAL0, $message); # information level, Local0 facility
=over 4
@@ -1095,79 +1012,22 @@ Log everything except informational messages:
Log critical messages, errors and warnings:
- setlogmask( LOG_MASK(LOG_CRIT)
- | LOG_MASK(LOG_ERR)
- | LOG_MASK(LOG_WARNING) );
+ setlogmask( LOG_MASK(LOG_CRIT) | LOG_MASK(LOG_ERR) | LOG_MASK(LOG_WARNING) );
Log all messages up to debug:
setlogmask( LOG_UPTO(LOG_DEBUG) );
-=item B<setlogsock()>
-
-Sets the socket type and options to be used for the next call to C<openlog()>
-or C<syslog()>. Returns true on success, C<undef> on failure.
-
-Being Perl-specific, this function has evolved along time. It can currently
-be called as follow:
-
-=over
+=item B<setlogsock($sock_type)>
-=item *
-
-C<setlogsock($sock_type)>
-
-=item *
+=item B<setlogsock($sock_type, $stream_location)> (added in Perl 5.004_02)
-C<setlogsock($sock_type, $stream_location)> (added in Perl 5.004_02)
-
-=item *
-
-C<setlogsock($sock_type, $stream_location, $sock_timeout)> (added in
-C<Sys::Syslog> 0.25)
-
-=item *
-
-C<setlogsock(\%options)> (added in C<Sys::Syslog> 0.28)
-
-=back
+=item B<setlogsock($sock_type, $stream_location, $sock_timeout)> (added in 0.25)
-The available options are:
-
-=over
-
-=item *
-
-C<type> - equivalent to C<$sock_type>, selects the socket type (or
-"mechanism"). An array reference can be passed to specify several
-mechanisms to try, in the given order.
-
-=item *
-
-C<path> - equivalent to C<$stream_location>, sets the stream location.
-Defaults to standard Unix location, or C<_PATH_LOG>.
-
-=item *
-
-C<timeout> - equivalent to C<$sock_timeout>, sets the socket timeout
-in seconds. Defaults to 0 on all systems except S<Mac OS X> where it
-is set to 0.25 sec.
-
-=item *
-
-C<host> - sets the hostname to send the messages to. Defaults to
-the local host.
-
-=item *
-
-C<port> - sets the TCP or UDP port to connect to. Defaults to the
-first standard syslog port available on the system.
-
-=back
-
-
-The available mechanisms are:
+Sets the socket type to be used for the next call to
+C<openlog()> or C<syslog()> and returns true on success,
+C<undef> on failure. The available mechanisms are:
=over
@@ -1184,38 +1044,39 @@ added in C<Sys::Syslog> 0.19).
=item *
C<"tcp"> - connect to a TCP socket, on the C<syslog/tcp> or C<syslogng/tcp>
-service. See also the C<host>, C<port> and C<timeout> options.
+service. If defined, the second parameter is used as a hostname to connect to.
=item *
C<"udp"> - connect to a UDP socket, on the C<syslog/udp> service.
-See also the C<host>, C<port> and C<timeout> options.
+If defined, the second parameter is used as a hostname to connect to,
+and the third parameter as the timeout used to check for UDP response.
=item *
C<"inet"> - connect to an INET socket, either TCP or UDP, tried in that
-order. See also the C<host>, C<port> and C<timeout> options.
+order. If defined, the second parameter is used as a hostname to connect to.
=item *
C<"unix"> - connect to a UNIX domain socket (in some systems a character
-special device). The name of that socket is given by the C<path> option
-or, if omitted, the value returned by the C<_PATH_LOG> macro (if your
-system defines it), F</dev/log> or F</dev/conslog>, whichever is writable.
+special device). The name of that socket is the second parameter or, if
+you omit the second parameter, the value returned by the C<_PATH_LOG> macro
+(if your system defines it), or F</dev/log> or F</dev/conslog>, whatever is
+writable.
=item *
-C<"stream"> - connect to the stream indicated by the C<path> option, or,
-if omitted, the value returned by the C<_PATH_LOG> macro (if your system
-defines it), F</dev/log> or F</dev/conslog>, whichever is writable. For
-example Solaris and IRIX system may prefer C<"stream"> instead of C<"unix">.
+C<"stream"> - connect to the stream indicated by the pathname provided as
+the optional second parameter, or, if omitted, to F</dev/conslog>.
+For example Solaris and IRIX system may prefer C<"stream"> instead of C<"unix">.
=item *
-C<"pipe"> - connect to the named pipe indicated by the C<path> option,
-or, if omitted, to the value returned by the C<_PATH_LOG> macro (if your
-system defines it), or F</dev/log> (added in C<Sys::Syslog> 0.21).
-HP-UX is a system which uses such a named pipe.
+C<"pipe"> - connect to the named pipe indicated by the pathname provided as
+the optional second parameter, or, if omitted, to the value returned by
+the C<_PATH_LOG> macro (if your system defines it), or F</dev/log>
+(added in C<Sys::Syslog> 0.21).
=item *
@@ -1224,6 +1085,10 @@ option of C<openlog()>.
=back
+A reference to an array can also be passed as the first parameter.
+When this calling method is used, the array should contain a list of
+mechanisms which are attempted in order.
+
The default is to try C<native>, C<tcp>, C<udp>, C<unix>, C<pipe>, C<stream>,
C<console>.
Under systems with the Win32 API, C<eventlog> will be added as the first
@@ -1233,19 +1098,11 @@ Giving an invalid value for C<$sock_type> will C<croak>.
B<Examples>
-Select the UDP socket mechanism:
+Select the UDP socket mechanism:
setlogsock("udp");
-Send messages using the TCP socket mechanism on a custom port:
-
- setlogsock({ type => "tcp", port => 2486 });
-
-Send messages to a remote host using the TCP socket mechanism:
-
- setlogsock({ type => "tcp", host => $loghost });
-
-Try the native, UDP socket then UNIX domain socket mechanisms:
+Select the native, UDP socket then UNIX domain socket mechanisms:
setlogsock(["native", "udp", "unix"]);
@@ -1257,7 +1114,7 @@ Now that the "native" mechanism is supported by C<Sys::Syslog> and selected
by default, the use of the C<setlogsock()> function is discouraged because
other mechanisms are less portable across operating systems. Authors of
modules and programs that use this function, especially its cargo-cult form
-C<setlogsock("unix")>, are advised to remove any occurrence of it unless they
+C<setlogsock("unix")>, are advised to remove any occurence of it unless they
specifically want to use a given mechanism (like TCP or UDP to connect to
a remote host).
@@ -1535,40 +1392,8 @@ was unable to find an appropriate an appropriate device.
=back
-=head1 HISTORY
-
-C<Sys::Syslog> is a core module, part of the standard Perl distribution
-since 1990. At this time, modules as we know them didn't exist, the
-Perl library was a collection of F<.pl> files, and the one for sending
-syslog messages with was simply F<lib/syslog.pl>, included with Perl 3.0.
-It was converted as a module with Perl 5.0, but had a version number
-only starting with Perl 5.6. Here is a small table with the matching
-Perl and C<Sys::Syslog> versions.
-
- Sys::Syslog Perl
- ----------- ----
- undef 5.0.0 ~ 5.5.4
- 0.01 5.6.*
- 0.03 5.8.0
- 0.04 5.8.1, 5.8.2, 5.8.3
- 0.05 5.8.4, 5.8.5, 5.8.6
- 0.06 5.8.7
- 0.13 5.8.8
- 0.22 5.10.0
- 0.27 5.8.9, 5.10.1 ~ 5.14.2
- 0.29 5.16.0, 5.16.1
-
-
=head1 SEE ALSO
-=head2 Other modules
-
-L<Log::Log4perl> - Perl implementation of the Log4j API
-
-L<Log::Dispatch> - Dispatches messages to one or more outputs
-
-L<Log::Report> - Report a problem, with exceptions and language support
-
=head2 Manual Pages
L<syslog(3)>
@@ -1677,15 +1502,15 @@ L<http://cpanratings.perl.org/d/Sys-Syslog>
=item * RT: CPAN's request tracker
-L<http://rt.cpan.org/Dist/Display.html?Queue=Sys-Syslog>
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sys-Syslog>
=item * Search CPAN
L<http://search.cpan.org/dist/Sys-Syslog/>
-=item * MetaCPAN
+=item * Kobes' CPAN Search
-L<https://metacpan.org/module/Sys::Syslog>
+L<http://cpan.uwinnipeg.ca/dist/Sys-Syslog>
=item * Perl Documentation
@@ -1696,7 +1521,7 @@ L<http://perldoc.perl.org/Sys/Syslog.html>
=head1 COPYRIGHT
-Copyright (C) 1990-2012 by Larry Wall and others.
+Copyright (C) 1990-2008 by Larry Wall and others.
=head1 LICENSE
@@ -1738,6 +1563,7 @@ but also has this strange piece of code:
I don't know what bug the author referred to.
- L<http://www.tpc.int/>
+- L<ftp://ftp.tpc.int/tpc/server/UNIX/>
- L<ftp://ftp-usa.tpc.int/pub/tpc/server/UNIX/>
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/bin/prove b/gnu/usr.bin/perl/cpan/Test-Harness/bin/prove
index 968fa7311d4..a592a80f0d5 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/bin/prove
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/bin/prove
@@ -1,7 +1,6 @@
#!/usr/bin/perl -w
use strict;
-use warnings;
use App::Prove;
my $app = App::Prove->new;
@@ -22,56 +21,50 @@ prove - Run tests through a TAP harness.
Boolean options:
- -v, --verbose Print all test lines.
- -l, --lib Add 'lib' to the path for your tests (-Ilib).
- -b, --blib Add 'blib/lib' and 'blib/arch' to the path for
- your tests
- -s, --shuffle Run the tests in random order.
- -c, --color Colored test output (default).
- --nocolor Do not color test output.
- --count Show the X/Y test count when not verbose
- (default)
- --nocount Disable the X/Y test count.
- -D --dry Dry run. Show test that would have run.
- -f, --failures Show failed tests.
- -o, --comments Show comments.
- --ignore-exit Ignore exit status from test scripts.
- -m, --merge Merge test scripts' STDERR with their STDOUT.
- -r, --recurse Recursively descend into directories.
- --reverse Run the tests in reverse order.
- -q, --quiet Suppress some test output while running tests.
- -Q, --QUIET Only print summary results.
- -p, --parse Show full list of TAP parse errors, if any.
- --directives Only show results with TODO or SKIP directives.
- --timer Print elapsed time after each test.
- --trap Trap Ctrl-C and print summary on interrupt.
- --normalize Normalize TAP output in verbose output
- -T Enable tainting checks.
- -t Enable tainting warnings.
- -W Enable fatal warnings.
- -w Enable warnings.
- -h, --help Display this help
- -?, Display this help
- -H, --man Longer manpage for prove
- --norc Don't process default .proverc
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' and 'blib/arch' to the path for your tests
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ --count Show the X/Y test count when not verbose (default)
+ --nocount Disable the X/Y test count.
+ -D --dry Dry run. Show test that would have run.
+ --ext Set the extension for tests (default '.t')
+ -f, --failures Show failed tests.
+ -o, --comments Show comments.
+ --fork Fork to run harness in multiple processes.
+ --ignore-exit Ignore exit status from test scripts.
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ --normalize Normalize TAP output in verbose output
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
Options that take arguments:
- -I Library paths to include.
- -P Load plugin (searches App::Prove::Plugin::*.)
- -M Load a module.
- -e, --exec Interpreter to run the tests ('' for compiled
- tests.)
- --ext Set the extension for tests (default '.t')
- --harness Define test harness to use. See TAP::Harness.
- --formatter Result formatter to use. See FORMATTERS.
- --source Load and/or configure a SourceHandler. See
- SOURCE HANDLERS.
- -a, --archive out.tgz Store the resulting TAP in an archive file.
- -j, --jobs N Run N test jobs in parallel (try 9.)
- --state=opts Control prove's persistent state.
- --rc=rcfile Process options from rcfile
- --rules Rules for parallel vs sequential processing.
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See TAP::Harness.
+ -a, --archive Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
=head1 NOTES
@@ -83,7 +76,7 @@ in F<.proverc> are specified in the same way as command line options:
# .proverc
--state=hot,fast,save
- -j9
+ -j9 --fork
Additional option files may be specified with the C<--rc> option.
Default option file processing is disabled by the C<--norc> option.
@@ -107,12 +100,12 @@ matching the pattern C<t/*.t>.
=head2 Colored Test Output
-Colored test output using L<TAP::Formatter::Color> is the default, but
-if output is not to a terminal, color is disabled. You can override this by
-adding the C<--color> switch.
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
Color support requires L<Term::ANSIColor> on Unix-like platforms and
-L<Win32::Console> on windows. If the necessary module is not installed
+L<Win32::Console> windows. If the necessary module is not installed
colored output will not be available.
=head2 Exit Code
@@ -125,7 +118,7 @@ It is possible to supply arguments to tests. To do so separate them from
prove's own arguments with the arisdottle, '::'. For example
prove -v t/mytest.t :: --url http://example.com
-
+
would run F<t/mytest.t> with the options '--url http://example.com'.
When running multiple tests they will each receive the same arguments.
@@ -144,9 +137,9 @@ switch:
If you need to make sure your diagnostics are displayed in the correct
order relative to test results you can use the C<--merge> option to
-merge the test scripts' STDERR into their STDOUT.
+merge the test scripts' STDERR into their STDOUT.
-This guarantees that STDOUT (where the test results appear) and STDERR
+This guarantees that STDOUT (where the test results appear) and STDOUT
(where the diagnostics appear) will stay in sync. The harness will
display any diagnostics your tests emit on STDERR.
@@ -155,11 +148,6 @@ that appears on STDERR looks like a test result the test harness will
get confused. Use this option only if you understand the consequences
and can live with the risk.
-=head2 C<--trap>
-
-The C<--trap> option will attempt to trap SIGINT (Ctrl-C) during a test
-run and display the test summary even if the run is interrupted
-
=head2 C<--state>
You can ask C<prove> to remember the state of previous test runs and
@@ -187,7 +175,7 @@ Run only the tests that failed on the last run.
# Run all tests
$ prove -b --state=save
-
+
# Run failures
$ prove -b --state=failed
@@ -236,7 +224,7 @@ Run the tests in slowest to fastest order. This is useful in conjunction
with the C<-j> parallel testing switch to ensure that your slowest tests
start running first.
- $ prove -b --state=slow -j9
+ $ prove -b --state=slow -j9
=item C<fast>
@@ -266,61 +254,6 @@ The C<--state> switch may be used more than once.
$ prove -b --state=hot --state=all,save
-=head2 --rules
-
-The C<--rules> option is used to control which tests are run sequentially and
-which are run in parallel, if the C<--jobs> option is specified. The option may
-be specified multiple times, and the order matters.
-
-The most practical use is likely to specify that some tests are not
-"parallel-ready". Since mentioning a file with --rules doesn't cause it to
-be selected to run as a test, you can "set and forget" some rules preferences in
-your .proverc file. Then you'll be able to take maximum advantage of the
-performance benefits of parallel testing, while some exceptions are still run
-in parallel.
-
-=head3 --rules examples
-
- # All tests are allowed to run in parallel, except those starting with "p"
- --rules='seq=t/p*.t' --rules='par=**'
-
- # All tests must run in sequence except those starting with "p", which should be run parallel
- --rules='par=t/p*.t'
-
-=head3 --rules resolution
-
-=over 4
-
-=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
-
-=item * "First match wins". The first rule that matches a test will be the one that applies.
-
-=item * Any test which does not match a rule will be run in sequence at the end of the run.
-
-=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
-
-=item * Specifying a rule to allow tests to run in parallel does not make them run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
-
-=back
-
-=head3 --rules Glob-style pattern matching
-
-We implement our own glob-style pattern matching for --rules. Here are the
-supported patterns:
-
- ** is any number of characters, including /, within a pathname
- * is zero or more characters within a filename/directory name
- ? is exactly one character within a filename/directory name
- {foo,bar,baz} is any of foo, bar or baz.
- \ is an escape character
-
-=head3 More advanced specifications for parallel vs sequence run rules
-
-If you need more advanced management of what runs in parallel vs in sequence, see
-the associated 'rules' documentation in L<TAP::Harness> and L<TAP::Parser::Scheduler>.
-If what's possible directly through C<prove> is not sufficient, you can write your own
-harness to access these features directly.
-
=head2 @INC
prove introduces a separation between "options passed to the perl which
@@ -335,43 +268,11 @@ via the C<-Ilib> option to F<prove>.
Normally when a Perl program is run in taint mode the contents of the
C<PERL5LIB> environment variable do not appear in C<@INC>.
-Because C<PERL5LIB> is often used during testing to add build
-directories to C<@INC> prove passes the names of any directories found
-in C<PERL5LIB> as -I switches. The net effect of this is that
-C<PERL5LIB> is honoured even when prove is run in taint mode.
-
-
-=head1 FORMATTERS
-
-You can load a custom L<TAP::Parser::Formatter>:
-
- prove --formatter MyFormatter
-
-=head1 SOURCE HANDLERS
-
-You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
-parser interprets particular I<sources> of TAP.
-
- prove --source MyHandler --source YetAnother t
-
-If you want to provide config to the source you can use:
-
- prove --source MyCustom \
- --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
- --source File --file-option extensions=.txt --file-option extensions=.tmp t
- --source pgTAP --pgtap-option pset=format=html --pgtap-option pset=border=2
-
-Each C<--$source-option> option must specify a key/value pair separated by an
-C<=>. If an option can take multiple values, just specify it multiple times,
-as with the C<extensions=> examples above. If the option should be a hash
-reference, specify the value as a second pair separated by a C<=>, as in the
-C<pset=> examples above (escape C<=> with a backslash).
-
-All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
-C<sources> parameter.
-
-See L<TAP::Parser::IteratorFactory> for more details on how configuration is
-passed to I<SourceHandlers>.
+Because C<PERL5LIB> is often used during testing to add build directories
+to C<@INC> prove (actually L<TAP::Parser::Source::Perl>) passes the
+names of any directories found in C<PERL5LIB> as -I switches. The net
+effect of this is that C<PERL5LIB> is honoured even when prove is run in
+taint mode.
=head1 PLUGINS
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove.pm
index 44aaf6dda30..fd431ed2f05 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove.pm
@@ -1,28 +1,27 @@
package App::Prove;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
+use TAP::Object ();
use TAP::Harness;
-use Text::ParseWords qw(shellwords);
+use TAP::Parser::Utils qw( split_shell );
use File::Spec;
use Getopt::Long;
use App::Prove::State;
use Carp;
-use base 'TAP::Object';
-
=head1 NAME
App::Prove - Implements the C<prove> command.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -52,13 +51,15 @@ use constant PLUGINS => 'App::Prove::Plugin';
my @ATTR;
BEGIN {
+ @ISA = qw(TAP::Object);
+
@ATTR = qw(
archive argv blib show_count color directives exec failures comments
formatter harness includes modules plugins jobs lib merge parse quiet
really_quiet recurse backwards shuffle taint_fail taint_warn timer
verbose warnings_fail warnings_warn show_help show_man show_version
- state_class test_args state dry extensions ignore_exit rules state_manager
- normalize sources tapversion trap
+ state_class test_args state dry extension ignore_exit rules state_manager
+ normalize
);
__PACKAGE__->mk_methods(@ATTR);
}
@@ -80,12 +81,8 @@ sub _initialize {
my $self = shift;
my $args = shift || {};
- my @is_array = qw(
- argv rc_opts includes modules state plugins rules sources
- );
-
# setup defaults:
- for my $key (@is_array) {
+ for my $key (qw( argv rc_opts includes modules state plugins rules )) {
$self->{$key} = [];
}
$self->{harness_class} = 'TAP::Harness';
@@ -200,58 +197,49 @@ sub process_args {
{
local @ARGV = @args;
- Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));
+ Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
# Don't add coderefs to GetOptions
GetOptions(
- 'v|verbose' => \$self->{verbose},
- 'f|failures' => \$self->{failures},
- 'o|comments' => \$self->{comments},
- 'l|lib' => \$self->{lib},
- 'b|blib' => \$self->{blib},
- 's|shuffle' => \$self->{shuffle},
- 'color!' => \$self->{color},
- 'colour!' => \$self->{color},
- 'count!' => \$self->{show_count},
- 'c' => \$self->{color},
- 'D|dry' => \$self->{dry},
- 'ext=s@' => sub {
- my ( $opt, $val ) = @_;
-
- # Workaround for Getopt::Long 2.25 handling of
- # multivalue options
- push @{ $self->{extensions} ||= [] }, $val;
- },
- 'harness=s' => \$self->{harness},
- 'ignore-exit' => \$self->{ignore_exit},
- 'source=s@' => $self->{sources},
- 'formatter=s' => \$self->{formatter},
- 'r|recurse' => \$self->{recurse},
- 'reverse' => \$self->{backwards},
- 'p|parse' => \$self->{parse},
- 'q|quiet' => \$self->{quiet},
- 'Q|QUIET' => \$self->{really_quiet},
- 'e|exec=s' => \$self->{exec},
- 'm|merge' => \$self->{merge},
- 'I=s@' => $self->{includes},
- 'M=s@' => $self->{modules},
- 'P=s@' => $self->{plugins},
- 'state=s@' => $self->{state},
- 'directives' => \$self->{directives},
- 'h|help|?' => \$self->{show_help},
- 'H|man' => \$self->{show_man},
- 'V|version' => \$self->{show_version},
- 'a|archive=s' => \$self->{archive},
- 'j|jobs=i' => \$self->{jobs},
- 'timer' => \$self->{timer},
- 'T' => \$self->{taint_fail},
- 't' => \$self->{taint_warn},
- 'W' => \$self->{warnings_fail},
- 'w' => \$self->{warnings_warn},
- 'normalize' => \$self->{normalize},
- 'rules=s@' => $self->{rules},
- 'tapversion=s' => \$self->{tapversion},
- 'trap' => \$self->{trap},
+ 'v|verbose' => \$self->{verbose},
+ 'f|failures' => \$self->{failures},
+ 'o|comments' => \$self->{comments},
+ 'l|lib' => \$self->{lib},
+ 'b|blib' => \$self->{blib},
+ 's|shuffle' => \$self->{shuffle},
+ 'color!' => \$self->{color},
+ 'colour!' => \$self->{color},
+ 'count!' => \$self->{show_count},
+ 'c' => \$self->{color},
+ 'D|dry' => \$self->{dry},
+ 'ext=s' => \$self->{extension},
+ 'harness=s' => \$self->{harness},
+ 'ignore-exit' => \$self->{ignore_exit},
+ 'formatter=s' => \$self->{formatter},
+ 'r|recurse' => \$self->{recurse},
+ 'reverse' => \$self->{backwards},
+ 'p|parse' => \$self->{parse},
+ 'q|quiet' => \$self->{quiet},
+ 'Q|QUIET' => \$self->{really_quiet},
+ 'e|exec=s' => \$self->{exec},
+ 'm|merge' => \$self->{merge},
+ 'I=s@' => $self->{includes},
+ 'M=s@' => $self->{modules},
+ 'P=s@' => $self->{plugins},
+ 'state=s@' => $self->{state},
+ 'directives' => \$self->{directives},
+ 'h|help|?' => \$self->{show_help},
+ 'H|man' => \$self->{show_man},
+ 'V|version' => \$self->{show_version},
+ 'a|archive=s' => \$self->{archive},
+ 'j|jobs=i' => \$self->{jobs},
+ 'timer' => \$self->{timer},
+ 'T' => \$self->{taint_fail},
+ 't' => \$self->{taint_warn},
+ 'W' => \$self->{warnings_fail},
+ 'w' => \$self->{warnings_warn},
+ 'normalize' => \$self->{normalize},
+ 'rules=s@' => $self->{rules},
) or croak('Unable to continue');
# Stash the remainder of argv for later
@@ -295,8 +283,6 @@ sub _get_args {
my %args;
- $args{trap} = 1 if $self->trap;
-
if ( defined $self->color ? $self->color : $self->_color_default ) {
$args{color} = 1;
}
@@ -324,11 +310,6 @@ sub _get_args {
$args{formatter_class} = $formatter;
}
- for my $handler ( @{ $self->sources } ) {
- my ( $name, $config ) = $self->_parse_source($handler);
- $args{sources}->{$name} = $config;
- }
-
if ( $self->ignore_exit ) {
$args{ignore_exit} = 1;
}
@@ -368,8 +349,6 @@ sub _get_args {
$args{exec} = [ split( /\s+/, $self->exec ) ]
if ( defined( $self->exec ) );
- $args{version} = $self->tapversion if defined( $self->tapversion );
-
if ( defined( my $test_args = $self->test_args ) ) {
$args{test_args} = $test_args;
}
@@ -432,42 +411,6 @@ sub _load_extensions {
$self->_load_extension( $_, @search ) for @$ext;
}
-sub _parse_source {
- my ( $self, $handler ) = @_;
-
- # Load any options.
- ( my $opt_name = lc $handler ) =~ s/::/-/g;
- local @ARGV = @{ $self->{argv} };
- my %config;
- Getopt::Long::GetOptions(
- "$opt_name-option=s%" => sub {
- my ( $name, $k, $v ) = @_;
- if ( $v =~ /(?<!\\)=/ ) {
-
- # It's a hash option.
- croak "Option $name must be consistently used as a hash"
- if exists $config{$k} && ref $config{$k} ne 'HASH';
- $config{$k} ||= {};
- my ( $hk, $hv ) = split /(?<!\\)=/, $v, 2;
- $config{$k}{$hk} = $hv;
- }
- else {
- $v =~ s/\\=/=/g;
- if ( exists $config{$k} ) {
- $config{$k} = [ $config{$k} ]
- unless ref $config{$k} eq 'ARRAY';
- push @{ $config{$k} } => $v;
- }
- else {
- $config{$k} = $v;
- }
- }
- }
- );
- $self->{argv} = \@ARGV;
- return ( $handler, \%config );
-}
-
=head3 C<run>
Perform whatever actions the command line args specified. The C<prove>
@@ -518,8 +461,8 @@ sub _get_tests {
my $self = shift;
my $state = $self->state_manager;
- my $ext = $self->extensions;
- $state->extensions($ext) if defined $ext;
+ my $ext = $self->extension;
+ $state->extension($ext) if defined $ext;
if ( defined( my $state_switch = $self->state ) ) {
$state->apply_switch(@$state_switch);
}
@@ -573,7 +516,7 @@ sub _get_switches {
push @switches, '-w';
}
- push @switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} ) if defined $ENV{HARNESS_PERL_SWITCHES};
+ push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
return @switches ? \@switches : ();
}
@@ -681,7 +624,7 @@ calling C<run>.
=item C<exec>
-=item C<extensions>
+=item C<extension>
=item C<failures>
@@ -743,10 +686,6 @@ calling C<run>.
=item C<warnings_warn>
-=item C<tapversion>
-
-=item C<trap>
-
=back
=head1 PLUGINS
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State.pm
index 519ba01d6c7..202f7aadd3b 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State.pm
@@ -1,7 +1,7 @@
package App::Prove::State;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
use File::Find;
use File::Spec;
@@ -10,9 +10,10 @@ use Carp;
use App::Prove::State::Result;
use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
-use base 'TAP::Base';
+use TAP::Base;
BEGIN {
+ @ISA = qw( TAP::Base );
__PACKAGE__->mk_methods('result_class');
}
@@ -25,11 +26,11 @@ App::Prove::State - State storage for the C<prove> command.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -40,7 +41,7 @@ and the operations that may be performed on it.
=head1 SYNOPSIS
# Re-run failed tests
- $ prove --state=failed,save -rbv
+ $ prove --state=fail,save -rbv
=cut
@@ -58,9 +59,9 @@ Accepts a hashref with the following key/value pairs:
The filename of the data store holding the data that App::Prove::State reads.
-=item * C<extensions> (optional)
+=item * C<extension> (optional)
-The test name extensions. Defaults to C<.t>.
+The test name extension. Defaults to C<.t>.
=item * C<result_class> (optional)
@@ -76,10 +77,10 @@ sub new {
my %args = %{ shift || {} };
my $self = bless {
- select => [],
- seq => 1,
- store => delete $args{store},
- extensions => ( delete $args{extensions} || ['.t'] ),
+ select => [],
+ seq => 1,
+ store => delete $args{store},
+ extension => ( delete $args{extension} || '.t' ),
result_class =>
( delete $args{result_class} || 'App::Prove::State::Result' ),
}, $class;
@@ -104,17 +105,17 @@ identical interface.
=cut
-=head2 C<extensions>
+=head2 C<extension>
-Get or set the list of extensions that files must have in order to be
-considered tests. Defaults to ['.t'].
+Get or set the extension files must have in order to be considered
+tests. Defaults to '.t'.
=cut
-sub extensions {
+sub extension {
my $self = shift;
- $self->{extensions} = shift if @_;
- return $self->{extensions};
+ $self->{extension} = shift if @_;
+ return $self->{extension};
}
=head2 C<results>
@@ -216,70 +217,48 @@ sub apply_switch {
my %handler = (
last => sub {
$self->_select(
- limit => shift,
where => sub { $_->generation >= $last_gen },
order => sub { $_->sequence }
);
},
failed => sub {
$self->_select(
- limit => shift,
where => sub { $_->result != 0 },
order => sub { -$_->result }
);
},
passed => sub {
- $self->_select(
- limit => shift,
- where => sub { $_->result == 0 }
- );
+ $self->_select( where => sub { $_->result == 0 } );
},
all => sub {
- $self->_select( limit => shift );
+ $self->_select();
},
todo => sub {
$self->_select(
- limit => shift,
where => sub { $_->num_todo != 0 },
order => sub { -$_->num_todo; }
);
},
hot => sub {
$self->_select(
- limit => shift,
where => sub { defined $_->last_fail_time },
order => sub { $now - $_->last_fail_time }
);
},
slow => sub {
- $self->_select(
- limit => shift,
- order => sub { -$_->elapsed }
- );
+ $self->_select( order => sub { -$_->elapsed } );
},
fast => sub {
- $self->_select(
- limit => shift,
- order => sub { $_->elapsed }
- );
+ $self->_select( order => sub { $_->elapsed } );
},
new => sub {
- $self->_select(
- limit => shift,
- order => sub { -$_->mtime }
- );
+ $self->_select( order => sub { -$_->mtime } );
},
old => sub {
- $self->_select(
- limit => shift,
- order => sub { $_->mtime }
- );
+ $self->_select( order => sub { $_->mtime } );
},
fresh => sub {
- $self->_select(
- limit => shift,
- where => sub { $_->mtime >= $last_run_time }
- );
+ $self->_select( where => sub { $_->mtime >= $last_run_time } );
},
save => sub {
$self->{should_save}++;
@@ -366,10 +345,6 @@ sub _query_clause {
} @got;
}
- if ( my $limit = $clause->{limit} ) {
- @got = splice @got, 0, $limit if @got > $limit;
- }
-
return @got;
}
@@ -380,11 +355,8 @@ sub _get_raw_tests {
my @tests;
# Do globbing on Win32.
- if (NEED_GLOB) {
- eval "use File::Glob::Windows"; # [49732]
- @argv = map { glob "$_" } @argv;
- }
- my $extensions = $self->{extensions};
+ @argv = map { glob "$_" } @argv if NEED_GLOB;
+ my $extension = $self->{extension};
for my $arg (@argv) {
if ( '-' eq $arg ) {
@@ -396,26 +368,23 @@ sub _get_raw_tests {
push @tests,
sort -d $arg
? $recurse
- ? $self->_expand_dir_recursive( $arg, $extensions )
- : map { glob( File::Spec->catfile( $arg, "*$_" ) ) }
- @{$extensions}
+ ? $self->_expand_dir_recursive( $arg, $extension )
+ : glob( File::Spec->catfile( $arg, "*$extension" ) )
: $arg;
}
return @tests;
}
sub _expand_dir_recursive {
- my ( $self, $dir, $extensions ) = @_;
+ my ( $self, $dir, $extension ) = @_;
my @tests;
- my $ext_string = join( '|', map {quotemeta} @{$extensions} );
-
find(
{ follow => 1, #21938
follow_skip => 2,
wanted => sub {
-f
- && /(?:$ext_string)$/
+ && /\Q$extension\E$/
&& push @tests => $File::Find::name;
}
},
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result.pm
index 8e44ea3a4b1..274676a62f9 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result.pm
@@ -1,10 +1,10 @@
package App::Prove::State::Result;
use strict;
-use warnings;
use Carp 'croak';
use App::Prove::State::Result::Test;
+use vars qw($VERSION);
use constant STATE_VERSION => 1;
@@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -29,7 +29,7 @@ single test suite run.
=head1 SYNOPSIS
# Re-run failed tests
- $ prove --state=failed,save -rbv
+ $ prove --state=fail,save -rbv
=cut
@@ -223,7 +223,7 @@ sub raw {
my %raw = %$self;
my %tests;
- for my $test ( $self->tests ) {
+ foreach my $test ( $self->tests ) {
$tests{ $test->name } = $test->raw;
}
$raw{tests} = \%tests;
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm
index 21f20a12e61..231f78919e2 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm
@@ -1,7 +1,8 @@
package App::Prove::State::Result::Test;
use strict;
-use warnings;
+
+use vars qw($VERSION);
=head1 NAME
@@ -9,11 +10,11 @@ App::Prove::State::Result::Test - Individual test results.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -24,7 +25,7 @@ single test.
=head1 SYNOPSIS
# Re-run failed tests
- $ prove --state=failed,save -rbv
+ $ prove --state=fail,save -rbv
=cut
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Base.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Base.pm
index 02f8b5e48ce..f88ad11134c 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Base.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Base.pm
@@ -1,9 +1,11 @@
package TAP::Base;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Object';
+use TAP::Object;
+
+@ISA = qw(TAP::Object);
=head1 NAME
@@ -12,11 +14,11 @@ and L<TAP::Harness>
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
use constant GOT_TIME_HIRES => do {
eval 'use Time::HiRes qw(time);';
@@ -27,7 +29,10 @@ use constant GOT_TIME_HIRES => do {
package TAP::Whatever;
- use base 'TAP::Base';
+ use TAP::Base;
+
+ use vars qw($VERSION @ISA);
+ @ISA = qw(TAP::Base);
# ... later ...
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Base.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Base.pm
index 1bb357d9bd0..f2b54a9ba3e 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Base.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Base.pm
@@ -1,14 +1,17 @@
package TAP::Formatter::Base;
use strict;
-use warnings;
-use base 'TAP::Base';
+use TAP::Base ();
use POSIX qw(strftime);
+use vars qw($VERSION @ISA);
+
my $MAX_ERRORS = 5;
my %VALIDATION_FOR;
BEGIN {
+ @ISA = qw(TAP::Base);
+
%VALIDATION_FOR = (
directives => sub { shift; shift },
verbosity => sub { shift; shift },
@@ -22,27 +25,13 @@ BEGIN {
show_count => sub { shift; shift },
stdout => sub {
my ( $self, $ref ) = @_;
-
$self->_croak("option 'stdout' needs a filehandle")
- unless $self->_is_filehandle($ref);
-
+ unless ( ref $ref || '' ) eq 'GLOB'
+ or eval { $ref->can('print') };
return $ref;
},
);
- sub _is_filehandle {
- my ( $self, $ref ) = @_;
-
- return 0 if !defined $ref;
-
- return 1 if ref $ref eq 'GLOB'; # lexical filehandle
- return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT
-
- return 1 if eval { $ref->can('print') };
-
- return 0;
- }
-
my @getter_setters = qw(
_longest
_printed_summary_header
@@ -54,15 +43,15 @@ BEGIN {
=head1 NAME
-TAP::Formatter::Base - Base class for harness output delegates
+TAP::Formatter::Console - Harness output delegate for default console output
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -217,7 +206,7 @@ sub prepare {
my $longest = 0;
- for my $test (@tests) {
+ foreach my $test (@tests) {
$longest = length $test if length $test > $longest;
}
@@ -268,15 +257,13 @@ sub _output_success {
$harness->summary( $aggregate );
-C<summary> prints the summary report after all tests are run. The first
-argument is an aggregate to summarise. An optional second argument may
-be set to a true value to indicate that the summary is being output as a
-result of an interrupted test run.
+C<summary> prints the summary report after all tests are run. The argument is
+an aggregate.
=cut
sub summary {
- my ( $self, $aggregate, $interrupted ) = @_;
+ my ( $self, $aggregate ) = @_;
return if $self->silent;
@@ -292,9 +279,6 @@ sub summary {
$self->_output( $self->_format_now(), "\n" );
}
- $self->_failure_output("Test run interrupted!\n")
- if $interrupted;
-
# TODO: Check this condition still works when all subtests pass but
# the exit status is nonzero
@@ -306,7 +290,7 @@ sub summary {
if ( $total != $passed or $aggregate->has_problems ) {
$self->_output("\nTest Summary Report");
$self->_output("\n-------------------\n");
- for my $test (@$tests) {
+ foreach my $test (@$tests) {
$self->_printed_summary_header(0);
my ($parser) = $aggregate->parsers($test);
$self->_output_summary_failure(
@@ -346,7 +330,7 @@ sub summary {
sprintf " Parse errors: %s\n",
shift @errors
);
- for my $error (@errors) {
+ foreach my $error (@errors) {
my $spaces = ' ' x 16;
$self->_failure_output("$spaces$error\n");
}
@@ -386,11 +370,9 @@ sub _summary_test_header {
my $spaces = ' ' x ( $self->_longest - length $test );
$spaces = ' ' unless $spaces;
my $output = $self->_get_output_method($parser);
- my $wait = $parser->wait;
- defined $wait or $wait = '(none)';
$self->$output(
- sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n",
- $wait, $parser->tests_run, scalar $parser->failed
+ sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n",
+ $parser->wait, $parser->tests_run, scalar $parser->failed
);
$self->_printed_summary_header(1);
}
@@ -440,7 +422,7 @@ sub _range {
@numbers = sort { $a <=> $b } @numbers;
my ( $min, @range );
- for my $i ( 0 .. $#numbers ) {
+ foreach my $i ( 0 .. $#numbers ) {
my $num = $numbers[$i];
my $next = $numbers[ $i + 1 ];
if ( defined $next && $next == $num + 1 ) {
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Color.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Color.pm
index d22752e12ee..349d3b84bf4 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Color.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Color.pm
@@ -1,11 +1,11 @@
package TAP::Formatter::Color;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
-use base 'TAP::Object';
+@ISA = qw(TAP::Object);
my $NO_COLOR;
@@ -71,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm
index 5ac9fa1a16e..aeca2f2b0d5 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console.pm
@@ -1,21 +1,24 @@
package TAP::Formatter::Console;
use strict;
-use warnings;
-use base 'TAP::Formatter::Base';
+use TAP::Formatter::Base ();
use POSIX qw(strftime);
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
+
=head1 NAME
TAP::Formatter::Console - Harness output delegate for default console output
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -28,7 +31,7 @@ This provides console orientated output formatting for TAP::Harness.
=head2 C<< open_test >>
-See L<TAP::Formatter::Base>
+See L<TAP::Formatter::base>
=cut
@@ -67,28 +70,16 @@ sub _set_colors {
}
}
-sub _failure_color {
- my ($self) = @_;
-
- return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red';
-}
-
-sub _success_color {
- my ($self) = @_;
-
- return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green';
-}
-
sub _output_success {
my ( $self, $msg ) = @_;
- $self->_set_colors( $self->_success_color() );
+ $self->_set_colors('green');
$self->_output($msg);
$self->_set_colors('reset');
}
sub _failure_output {
my $self = shift;
- $self->_set_colors( $self->_failure_color() );
+ $self->_set_colors('red');
my $out = join '', @_;
my $has_newline = chomp $out;
$self->_output($out);
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm
index 16ce97153d9..675512c71d0 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm
@@ -1,9 +1,11 @@
package TAP::Formatter::Console::Session;
use strict;
-use warnings;
+use TAP::Formatter::Session;
-use base 'TAP::Formatter::Session';
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
my @ACCESSOR;
@@ -26,11 +28,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -198,7 +200,7 @@ sub _closures {
}
}
- $formatter->_output( $self->_make_ok_line($time_report) );
+ $formatter->_output("ok$time_report\n");
}
},
};
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File.pm
index 2e72d914ba8..8514bc068bb 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File.pm
@@ -1,11 +1,13 @@
package TAP::Formatter::File;
use strict;
-use warnings;
+use TAP::Formatter::Base ();
use TAP::Formatter::File::Session;
use POSIX qw(strftime);
-use base 'TAP::Formatter::Base';
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Base);
=head1 NAME
@@ -13,11 +15,11 @@ TAP::Formatter::File - Harness output delegate for file output
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm
index 4719f22b1b6..c6abfd63bcc 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm
@@ -1,8 +1,11 @@
package TAP::Formatter::File::Session;
use strict;
-use warnings;
-use base 'TAP::Formatter::Session';
+use TAP::Formatter::Session;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Formatter::Session);
=head1 NAME
@@ -10,11 +13,11 @@ TAP::Formatter::File::Session - Harness output delegate for file output
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -100,7 +103,7 @@ sub close_test {
$formatter->_output( $pretty
. ( $self->{results} ? "\n" . $self->{results} : "" )
- . $self->_make_ok_line($time_report) );
+ . "ok$time_report\n" );
}
}
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Session.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Session.pm
index 120b4953c36..21767e5eba7 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Session.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Formatter/Session.pm
@@ -1,9 +1,11 @@
package TAP::Formatter::Session;
use strict;
-use warnings;
+use TAP::Base;
-use base 'TAP::Base';
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
my @ACCESSOR;
@@ -23,11 +25,11 @@ TAP::Formatter::Session - Abstract base class for harness output delegate
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 METHODS
@@ -178,9 +180,4 @@ sub _output_test_failure {
$formatter->_output("\n");
}
-sub _make_ok_line {
- my ( $self, $suffix ) = @_;
- return "ok$suffix\n";
-}
-
1;
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Harness.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Harness.pm
index 53d8d18bea6..749e7af4166 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Harness.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Harness.pm
@@ -1,14 +1,17 @@
package TAP::Harness;
use strict;
-use warnings;
use Carp;
use File::Spec;
use File::Path;
use IO::Handle;
-use base 'TAP::Base';
+use TAP::Base;
+
+use vars qw($VERSION @ISA);
+
+@ISA = qw(TAP::Base);
=head1 NAME
@@ -16,11 +19,11 @@ TAP::Harness - Run test scripts with statistics
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
@@ -81,9 +84,6 @@ BEGIN {
test_args => sub { shift; shift },
ignore_exit => sub { shift; shift },
rules => sub { shift; shift },
- sources => sub { shift; shift },
- version => sub { shift; shift },
- trap => sub { shift; shift },
);
for my $method ( sort keys %VALIDATION_FOR ) {
@@ -192,16 +192,6 @@ only makes sense in the context of tests written in Perl.
A reference to an C<@INC> style array of arguments to be passed to each
test program.
- test_args => ['foo', 'bar'],
-
-if you want to pass different arguments to each test then you should
-pass a hash of arrays, keyed by the alias for each test:
-
- test_args => {
- my_test => ['foo', 'bar'],
- other_test => ['baz'],
- }
-
=item * C<color>
Attempt to produce color output.
@@ -239,41 +229,11 @@ will be interpreted as raw TAP or as a TAP stream, respectively.
If C<merge> is true the harness will create parsers that merge STDOUT
and STDERR together for any processes they start.
-=item * C<sources>
-
-I<NEW to 3.18>.
-
-If set, C<sources> must be a hashref containing the names of the
-L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a
-hash of configuration that will be accessible to the source handlers via
-L<TAP::Parser::Source/config_for>.
-
-For example:
-
- sources => {
- Perl => { exec => '/path/to/custom/perl' },
- File => { extensions => [ '.tap', '.txt' ] },
- MyCustom => { some => 'config' },
- }
-
-The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
-are handled.
-
-For more details, see the C<sources> parameter in L<TAP::Parser/new>,
-L<TAP::Parser::Source>, and L<TAP::Parser::IteratorFactory>.
-
=item * C<aggregator_class>
The name of the class to use to aggregate test results. The default is
L<TAP::Parser::Aggregator>.
-=item * C<version>
-
-I<NEW to 3.22>.
-
-Assume this TAP version for L<TAP::Parser> instead of default TAP
-version 12.
-
=item * C<formatter_class>
The name of the class to use to format output. The default is
@@ -327,47 +287,25 @@ run only one test at a time.
=item * C<rules>
-A reference to a hash of rules that control which tests may be executed in
-parallel. If no rules are declared, all tests are eligible for being run in
-parallel. Here some simple examples. For the full details of the data structure
-and the related glob-style pattern matching, see
-L<TAP::Parser::Scheduler/"Rules data structure">.
-
- # Run all tests in sequence, except those starting with "p"
- $harness->rules({
- par => 't/p*.t'
- });
-
- # Run all tests in parallel, except those starting with "p"
- $harness->rules({
- seq => [
- { seq => 't/p*.t' },
- { par => '**' },
- ],
- });
-
- # Run some startup tests in sequence, then some parallel tests than some
- # teardown tests in sequence.
- $harness->rules({
- seq => [
- { seq => 't/startup/*.t' },
- { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
- { seq => 't/shutdown/*.t' },
- ],
-
- });
-
-This is an experimental feature and the interface may change.
+A reference to a hash of rules that control which tests may be
+executed in parallel. This is an experimental feature and the
+interface may change.
+
+ $harness->rules(
+ { par => [
+ { seq => '../ext/DB_File/t/*' },
+ { seq => '../ext/IO_Compress_Zlib/t/*' },
+ { seq => '../lib/CPANPLUS/*' },
+ { seq => '../lib/ExtUtils/t/*' },
+ '*'
+ ]
+ }
+ );
=item * C<stdout>
A filehandle for catching standard output.
-=item * C<trap>
-
-Attempt to print summary information if run is interrupted by
-SIGINT (Ctrl-C).
-
=back
Any keys for which the value is C<undef> will be ignored.
@@ -455,7 +393,7 @@ Any keys for which the value is C<undef> will be ignored.
$harness->runtests(@tests);
-Accepts an array of C<@tests> to be run. This should generally be the
+Accepts and array of C<@tests> to be run. This should generally be the
names of test files, but this is not required. Each element in C<@tests>
will be passed to C<TAP::Parser::new()> as a C<source>. See
L<TAP::Parser> for more information.
@@ -489,43 +427,23 @@ sub runtests {
$self->_make_callback( 'before_runtests', $aggregate );
$aggregate->start;
- my $finish = sub {
- my $interrupted = shift;
- $aggregate->stop;
- $self->summary( $aggregate, $interrupted );
- $self->_make_callback( 'after_runtests', $aggregate );
- };
- my $run = sub {
- $self->aggregate_tests( $aggregate, @tests );
- $finish->();
- };
-
- if ( $self->trap ) {
- local $SIG{INT} = sub {
- print "\n";
- $finish->(1);
- exit;
- };
- $run->();
- }
- else {
- $run->();
- }
+ $self->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop;
+ $self->summary($aggregate);
+ $self->_make_callback( 'after_runtests', $aggregate );
return $aggregate;
}
=head3 C<summary>
- $harness->summary( $aggregator );
-
-Output the summary for a L<TAP::Parser::Aggregator>.
+Output the summary for a TAP::Parser::Aggregator.
=cut
sub summary {
- my ( $self, @args ) = @_;
- $self->formatter->summary(@args);
+ my ( $self, $aggregate ) = @_;
+ $self->formatter->summary($aggregate);
}
sub _after_test {
@@ -615,7 +533,7 @@ sub _aggregate_single {
$harness->aggregate_tests( $aggregate, @tests );
Run the named tests and display a summary of result. Tests will be run
-in the order found.
+in the order found.
Test results will be added to the supplied L<TAP::Parser::Aggregator>.
C<aggregate_tests> may be called multiple times to run several sets of
@@ -643,23 +561,20 @@ are unsuitable for parallel execution.
Note that for simpler testing requirements it will often be possible to
replace the above code with a single call to C<runtests>.
-Each element of the C<@tests> array is either:
+Each elements of the @tests array is either
=over
-=item * the source name of a test to run
+=item * the file name of a test script to run
-=item * a reference to a [ source name, display name ] array
+=item * a reference to a [ file name, display name ] array
=back
-In the case of a perl test suite, typically I<source names> are simply the file
-names of the test scripts to run.
-
When you supply a separate display name it becomes possible to run a
test more than once; the display name is effectively the alias by which
the test is known inside the harness. The harness doesn't care if it
-runs the same test more than once when each invocation uses a
+runs the same script more than once when each invocation uses a
different name.
=cut
@@ -724,13 +639,59 @@ should be set higher.
##############################################################################
+=head1 SUBCLASSING
+
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
+don't like how a particular feature functions, just override the
+desired methods.
+
+=head2 Methods
+
+TODO: This is out of date
+
+The following methods are ones you may wish to override if you want to
+subclass C<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The
+argument is a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+This is created with C<< Benchmark->new >> and it the time the tests
+started. You can print a useful summary time, if desired, with:
+
+ $self->output(
+ timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
+
+=item * C<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+object for individual tests:
+
+ my $aggregate = $args->{aggregate};
+ my $tests = $args->{tests};
+
+ for my $name ( @$tests ) {
+ my ($parser) = $aggregate->parsers($test);
+ ... do something with $parser
+ }
+
+This is a bit clunky and will be cleaned up in a later release.
+
+=back
+
+=cut
+
sub _get_parser_args {
my ( $self, $job ) = @_;
my $test_prog = $job->filename;
my %args = ();
-
- $args{sources} = $self->sources if $self->sources;
-
my @switches;
@switches = $self->lib if $self->lib;
push @switches => $self->switches if $self->switches;
@@ -738,7 +699,6 @@ sub _get_parser_args {
$args{spool} = $self->_open_spool($test_prog);
$args{merge} = $self->merge;
$args{ignore_exit} = $self->ignore_exit;
- $args{version} = $self->version if $self->version;
if ( my $exec = $self->exec ) {
$args{exec}
@@ -757,19 +717,6 @@ sub _get_parser_args {
}
if ( defined( my $test_args = $self->test_args ) ) {
-
- if ( ref($test_args) eq 'HASH' ) {
-
- # different args for each test
- if ( exists( $test_args->{ $job->description } ) ) {
- $test_args = $test_args->{ $job->description };
- }
- else {
- $self->_croak( "TAP::Harness Can't find test_args for "
- . $job->description );
- }
- }
-
$args{test_args} = $test_args;
}
@@ -860,120 +807,6 @@ sub _croak {
return;
}
-1;
-
-__END__
-
-##############################################################################
-
-=head1 CONFIGURING
-
-C<TAP::Harness> is designed to be easy to configure.
-
-=head2 Plugins
-
-C<TAP::Parser> plugins let you change the way TAP is I<input> to and I<output>
-from the parser.
-
-L<TAP::Parser::SourceHandler>s handle TAP I<input>. You can configure them
-and load custom handlers using the C<sources> parameter to L</new>.
-
-L<TAP::Formatter>s handle TAP I<output>. You can load custom formatters by
-using the C<formatter_class> parameter to L</new>. To configure a formatter,
-you currently need to instantiate it outside of L<TAP::Harness> and pass it in
-with the C<formatter> parameter to L</new>. This I<may> be addressed by adding
-a I<formatters> parameter to L</new> in the future.
-
-=head2 C<Module::Build>
-
-L<Module::Build> version C<0.30> supports C<TAP::Harness>.
-
-To load C<TAP::Harness> plugins, you'll need to use the C<tap_harness_args>
-parameter to C<new>, typically from your C<Build.PL>. For example:
-
- Module::Build->new(
- module_name => 'MyApp',
- test_file_exts => [qw(.t .tap .txt)],
- use_tap_harness => 1,
- tap_harness_args => {
- sources => {
- MyCustom => {},
- File => {
- extensions => ['.tap', '.txt'],
- },
- },
- formatter_class => 'TAP::Formatter::HTML',
- },
- build_requires => {
- 'Module::Build' => '0.30',
- 'TAP::Harness' => '3.18',
- },
- )->create_build_script;
-
-See L</new>
-
-=head2 C<ExtUtils::MakeMaker>
-
-L<ExtUtils::MakeMaker> does not support L<TAP::Harness> out-of-the-box.
-
-=head2 C<prove>
-
-L<prove> supports C<TAP::Harness> plugins, and has a plugin system of its
-own. See L<prove/FORMATTERS>, L<prove/SOURCE HANDLERS> and L<App::Prove>
-for more details.
-
-=head1 WRITING PLUGINS
-
-If you can't configure C<TAP::Harness> to do what you want, and you can't find
-an existing plugin, consider writing one.
-
-The two primary use cases supported by L<TAP::Harness> for plugins are I<input>
-and I<output>:
-
-=over 2
-
-=item Customize how TAP gets into the parser
-
-To do this, you can either extend an existing L<TAP::Parser::SourceHandler>,
-or write your own. It's a pretty simple API, and they can be loaded and
-configured using the C<sources> parameter to L</new>.
-
-=item Customize how TAP results are output from the parser
-
-To do this, you can either extend an existing L<TAP::Formatter>, or write your
-own. Writing formatters are a bit more involved than writing a
-I<SourceHandler>, as you'll need to understand the L<TAP::Parser> API. A
-good place to start is by understanding how L</aggregate_tests> works.
-
-Custom formatters can be loaded configured using the C<formatter_class>
-parameter to L</new>.
-
-=back
-
-=head1 SUBCLASSING
-
-If you can't configure C<TAP::Harness> to do exactly what you want, and writing
-a plugin isn't an option, consider extending it. It is designed to be (mostly)
-easy to subclass, though the cases when sub-classing is necessary should be few
-and far between.
-
-=head2 Methods
-
-The following methods are ones you may wish to override if you want to
-subclass C<TAP::Harness>.
-
-=over 4
-
-=item L</new>
-
-=item L</runtests>
-
-=item L</summary>
-
-=back
-
-=cut
-
=head1 REPLACING
If you like the C<prove> utility and L<TAP::Parser> but you want your
@@ -992,4 +825,6 @@ L<Test::Harness>
=cut
+1;
+
# vim:ts=4:sw=4:et:sta
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Object.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Object.pm
index 21c53dc06a8..498bb805c91 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Object.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Object.pm
@@ -1,7 +1,7 @@
package TAP::Object;
use strict;
-use warnings;
+use vars qw($VERSION);
=head1 NAME
@@ -9,19 +9,22 @@ TAP::Object - Base class that provides common functionality to all C<TAP::*> mod
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
package TAP::Whatever;
use strict;
+ use vars qw(@ISA);
- use base 'TAP::Object';
+ use TAP::Object;
+
+ @ISA = qw(TAP::Object);
# new() implementation by TAP::Object
sub _initialize {
@@ -90,25 +93,6 @@ sub _croak {
return;
}
-=head3 C<_confess>
-
-Raise an exception using C<confess> from L<Carp>, eg:
-
- $self->_confess( 'why me?', 'aaarrgh!' );
-
-May also be called as a I<class> method.
-
- $class->_confess( 'this works too' );
-
-=cut
-
-sub _confess {
- my $proto = shift;
- require Carp;
- Carp::confess(@_);
- return;
-}
-
=head3 C<_construct>
Create a new instance of the specified class.
@@ -124,7 +108,7 @@ sub _construct {
unless ( $class->can('new') ) {
local $@;
eval "require $class";
- $self->_croak("Can't load $class: $@") if $@;
+ $self->_croak("Can't load $class") if $@;
}
return $class->new(@args);
@@ -140,7 +124,7 @@ Create simple getter/setters.
sub mk_methods {
my ( $class, @methods ) = @_;
- for my $method_name (@methods) {
+ foreach my $method_name (@methods) {
my $method = "${class}::$method_name";
no strict 'refs';
*$method = sub {
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser.pm
index 1ebb0db969c..ea3acd907ff 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser.pm
@@ -1,25 +1,18 @@
package TAP::Parser;
use strict;
-use warnings;
-
-use TAP::Parser::Grammar ();
-use TAP::Parser::Result ();
-use TAP::Parser::ResultFactory ();
-use TAP::Parser::Source ();
-use TAP::Parser::Iterator ();
-use TAP::Parser::IteratorFactory ();
-use TAP::Parser::SourceHandler::Executable ();
-use TAP::Parser::SourceHandler::Perl ();
-use TAP::Parser::SourceHandler::File ();
-use TAP::Parser::SourceHandler::RawTAP ();
-use TAP::Parser::SourceHandler::Handle ();
+use vars qw($VERSION @ISA);
-use Carp qw( confess );
-
-use base 'TAP::Base';
+use TAP::Base ();
+use TAP::Parser::Grammar ();
+use TAP::Parser::Result ();
+use TAP::Parser::ResultFactory ();
+use TAP::Parser::Source ();
+use TAP::Parser::Source::Perl ();
+use TAP::Parser::Iterator ();
+use TAP::Parser::IteratorFactory ();
-=encoding utf8
+use Carp qw( confess );
=head1 NAME
@@ -27,11 +20,11 @@ TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
my $DEFAULT_TAP_VERSION = 12;
my $MAX_TAP_VERSION = 13;
@@ -45,9 +38,11 @@ END {
}
BEGIN { # making accessors
+ @ISA = qw(TAP::Base);
+
__PACKAGE__->mk_methods(
qw(
- _iterator
+ _stream
_spool
exec
exit
@@ -61,16 +56,13 @@ BEGIN { # making accessors
start_time
end_time
skip_all
+ source_class
+ perl_source_class
grammar_class
- result_factory_class
iterator_factory_class
+ result_factory_class
)
);
-
- sub _stream { # deprecated
- my $self = shift;
- $self->_iterator(@_);
- }
} # done making accessors
=head1 SYNOPSIS
@@ -113,55 +105,39 @@ The arguments should be a hashref with I<one> of the following keys:
=item * C<source>
-I<CHANGED in 3.18>
+This is the preferred method of passing arguments to the constructor. To
+determine how to handle the source, the following steps are taken.
-This is the preferred method of passing input to the constructor.
+If the source contains a newline, it's assumed to be a string of raw TAP
+output.
-The C<source> is used to create a L<TAP::Parser::Source> that is passed to the
-L</iterator_factory_class> which in turn figures out how to handle the source and
-creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to
-read in the TAP stream.
+If the source is a reference, it's assumed to be something to pass to
+the L<TAP::Parser::Iterator::Stream> constructor. This is used
+internally and you should not use it.
-To configure the I<IteratorFactory> use the C<sources> parameter below.
+Otherwise, the parser does a C<-e> check to see if the source exists. If so,
+it attempts to execute the source and read the output as a stream. This is by
+far the preferred method of using the parser.
-Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
+ foreach my $file ( @test_files ) {
+ my $parser = TAP::Parser->new( { source => $file } );
+ # do stuff with the parser
+ }
=item * C<tap>
-I<CHANGED in 3.18>
-
The value should be the complete TAP output.
-The I<tap> is used to create a L<TAP::Parser::Source> that is passed to the
-L</iterator_factory_class> which in turn figures out how to handle the source and
-creates a <TAP::Parser::Iterator> for it. The iterator is used by the parser to
-read in the TAP stream.
-
-To configure the I<IteratorFactory> use the C<sources> parameter below.
-
-Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
-
=item * C<exec>
-Must be passed an array reference.
-
-The I<exec> array ref is used to create a L<TAP::Parser::Source> that is passed
-to the L</iterator_factory_class> which in turn figures out how to handle the
-source and creates a <TAP::Parser::Iterator> for it. The iterator is used by
-the parser to read in the TAP stream.
-
-By default the L<TAP::Parser::SourceHandler::Executable> class will create a
-L<TAP::Parser::Iterator::Process> object to handle the source. This passes the
-array reference strings as command arguments to L<IPC::Open3::open3|IPC::Open3>:
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
-If any C<test_args> are given they will be appended to the end of the command
-argument list.
-
-To configure the I<IteratorFactory> use the C<sources> parameter below.
-
-Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
+Note that C<source> and C<exec> are mutually exclusive.
=back
@@ -169,34 +145,6 @@ The following keys are optional.
=over 4
-=item * C<sources>
-
-I<NEW to 3.18>.
-
-If set, C<sources> must be a hashref containing the names of the
-L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a
-hash of configuration that will be accessible to the source handlers via
-L<TAP::Parser::Source/config_for>.
-
-For example:
-
- sources => {
- Perl => { exec => '/path/to/custom/perl' },
- File => { extensions => [ '.tap', '.txt' ] },
- MyCustom => { some => 'config' },
- }
-
-This will cause C<TAP::Parser> to pass custom configuration to two of the built-
-in source handlers - L<TAP::Parser::SourceHandler::Perl>,
-L<TAP::Parser::SourceHandler::File> - and attempt to load the C<MyCustom>
-class. See L<TAP::Parser::IteratorFactory/load_handlers> for more detail.
-
-The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
-are handled.
-
-See L<TAP::Parser::IteratorFactory>, L<TAP::Parser::SourceHandler> and subclasses for
-more details.
-
=item * C<callback>
If present, each callback corresponding to a given result type will be called
@@ -211,7 +159,7 @@ with the result as the argument if the C<run> method is used:
);
my $aggregator = TAP::Parser::Aggregator->new;
- for my $file ( @test_files ) {
+ foreach my $file ( @test_files ) {
my $parser = TAP::Parser->new(
{
source => $file,
@@ -229,13 +177,13 @@ be used when invoking the perl executable.
my $parser = TAP::Parser->new( {
source => $test_file,
- switches => [ '-Ilib' ],
+ switches => '-Ilib',
} );
=item * C<test_args>
-Used in conjunction with the C<source> and C<exec> option to supply a reference
-to an C<@ARGV> style array of arguments to pass to the test program.
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
=item * C<spool>
@@ -253,6 +201,20 @@ allow exact synchronization.
Subtleties of this behavior may be platform-dependent and may change in
the future.
+=item * C<source_class>
+
+This option was introduced to let you easily customize which I<source> class
+the parser should use. It defaults to L<TAP::Parser::Source>.
+
+See also L</make_source>.
+
+=item * C<perl_source_class>
+
+This option was introduced to let you easily customize which I<perl source>
+class the parser should use. It defaults to L<TAP::Parser::Source::Perl>.
+
+See also L</make_perl_source>.
+
=item * C<grammar_class>
This option was introduced to let you easily customize which I<grammar> class
@@ -260,6 +222,14 @@ the parser should use. It defaults to L<TAP::Parser::Grammar>.
See also L</make_grammar>.
+=item * C<iterator_factory_class>
+
+This option was introduced to let you easily customize which I<iterator>
+factory class the parser should use. It defaults to
+L<TAP::Parser::IteratorFactory>.
+
+See also L</make_iterator>.
+
=item * C<result_factory_class>
This option was introduced to let you easily customize which I<result>
@@ -268,14 +238,6 @@ L<TAP::Parser::ResultFactory>.
See also L</make_result>.
-=item * C<iterator_factory_class>
-
-I<CHANGED in 3.18>
-
-This option was introduced to let you easily customize which I<iterator>
-factory class the parser should use. It defaults to
-L<TAP::Parser::IteratorFactory>.
-
=back
=cut
@@ -283,9 +245,11 @@ L<TAP::Parser::IteratorFactory>.
# new() implementation supplied by TAP::Base
# This should make overriding behaviour of the Parser in subclasses easier:
+sub _default_source_class {'TAP::Parser::Source'}
+sub _default_perl_source_class {'TAP::Parser::Source::Perl'}
sub _default_grammar_class {'TAP::Parser::Grammar'}
-sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
+sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
##############################################################################
@@ -333,6 +297,20 @@ sub run {
##############################################################################
+=head3 C<make_source>
+
+Make a new L<TAP::Parser::Source> object and return it. Passes through any
+arguments given.
+
+The C<source_class> can be customized, as described in L</new>.
+
+=head3 C<make_perl_source>
+
+Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through
+any arguments given.
+
+The C<perl_source_class> can be customized, as described in L</new>.
+
=head3 C<make_grammar>
Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
@@ -340,6 +318,14 @@ arguments given.
The C<grammar_class> can be customized, as described in L</new>.
+=head3 C<make_iterator>
+
+Make a new L<TAP::Parser::Iterator> object using the parser's
+L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments
+given.
+
+The C<iterator_factory_class> can be customized, as described in L</new>.
+
=head3 C<make_result>
Make a new L<TAP::Parser::Result> object using the parser's
@@ -348,21 +334,28 @@ given.
The C<result_factory_class> can be customized, as described in L</new>.
-=head3 C<make_iterator_factory>
-
-I<NEW to 3.18>.
-
-Make a new L<TAP::Parser::IteratorFactory> object and return it. Passes through
-any arguments given.
-
-C<iterator_factory_class> can be customized, as described in L</new>.
-
=cut
# This should make overriding behaviour of the Parser in subclasses easier:
-sub make_iterator_factory { shift->iterator_factory_class->new(@_); }
-sub make_grammar { shift->grammar_class->new(@_); }
-sub make_result { shift->result_factory_class->make_result(@_); }
+sub make_source { shift->source_class->new(@_); }
+sub make_perl_source { shift->perl_source_class->new(@_); }
+sub make_grammar { shift->grammar_class->new(@_); }
+sub make_iterator { shift->iterator_factory_class->make_iterator(@_); }
+sub make_result { shift->result_factory_class->make_result(@_); }
+
+sub _iterator_for_source {
+ my ( $self, $source ) = @_;
+
+ # If the source has a get_stream method then use it. This makes it
+ # possible to pass a pre-existing source object to the parser's
+ # constructor.
+ if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
+ return $source->get_stream($self);
+ }
+ else {
+ return $self->iterator_factory_class->make_iterator($source);
+ }
+}
{
@@ -371,7 +364,9 @@ sub make_result { shift->result_factory_class->make_result(@_); }
my %initialize = (
version => $DEFAULT_TAP_VERSION,
plan => '', # the test plan (e.g., 1..3)
+ tap => '', # the TAP
tests_run => 0, # actual current test numbers
+ results => [], # TAP parser results
skipped => [], #
todo => [], #
passed => [], #
@@ -398,16 +393,18 @@ sub make_result { shift->result_factory_class->make_result(@_); }
);
my @class_overrides = qw(
+ source_class
+ perl_source_class
grammar_class
- result_factory_class
iterator_factory_class
+ result_factory_class
);
sub _initialize {
my ( $self, $arg_for ) = @_;
# everything here is basically designed to convert any TAP source to a
- # TAP::Parser::Iterator.
+ # stream.
# Shallow copy
my %args = %{ $arg_for || {} };
@@ -421,22 +418,19 @@ sub make_result { shift->result_factory_class->make_result(@_); }
$self->$key($val);
}
- my $iterator = delete $args{iterator};
- $iterator ||= delete $args{stream}; # deprecated
+ my $stream = delete $args{stream};
my $tap = delete $args{tap};
- my $version = delete $args{version};
- my $raw_source = delete $args{source};
- my $sources = delete $args{sources};
+ my $source = delete $args{source};
my $exec = delete $args{exec};
my $merge = delete $args{merge};
my $spool = delete $args{spool};
my $switches = delete $args{switches};
my $ignore_exit = delete $args{ignore_exit};
- my $test_args = delete $args{test_args} || [];
+ my @test_args = @{ delete $args{test_args} || [] };
- if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) {
+ if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
$self->_croak(
- "You may only choose one of 'exec', 'tap', 'source' or 'iterator'"
+ "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
);
}
@@ -444,43 +438,47 @@ sub make_result { shift->result_factory_class->make_result(@_); }
$self->_croak("Unknown options: @excess");
}
- # convert $tap & $exec to $raw_source equiv.
- my $type = '';
- my $source = TAP::Parser::Source->new;
if ($tap) {
- $type = 'raw TAP';
- $source->raw( \$tap );
+ $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
}
elsif ($exec) {
- $type = 'exec ' . $exec->[0];
- $source->raw( { exec => $exec } );
- }
- elsif ($raw_source) {
- $type = 'source ' . ref($raw_source) || $raw_source;
- $source->raw( ref($raw_source) ? $raw_source : \$raw_source );
- }
- elsif ($iterator) {
- $type = 'iterator ' . ref($iterator);
+ my $source = $self->make_source;
+ $source->source( [ @$exec, @test_args ] );
+ $source->merge($merge); # XXX should just be arguments?
+ $stream = $source->get_stream($self);
}
+ elsif ($source) {
+ if ( $source =~ /\n/ ) {
+ $stream
+ = $self->_iterator_for_source( [ split "\n" => $source ] );
+ }
+ elsif ( ref $source ) {
+ $stream = $self->_iterator_for_source($source);
+ }
+ elsif ( -e $source ) {
+ my $perl = $self->make_perl_source;
- if ( $source->raw ) {
- my $src_factory = $self->make_iterator_factory($sources);
- $source->merge($merge)->switches($switches)
- ->test_args($test_args);
- $iterator = $src_factory->make_iterator($source);
+ $perl->switches($switches)
+ if $switches;
+
+ $perl->merge($merge); # XXX args to new()?
+ $perl->source( [ $source, @test_args ] );
+ $stream = $perl->get_stream($self);
+ }
+ else {
+ $self->_croak("Cannot determine source for $source");
+ }
}
- unless ($iterator) {
- $self->_croak(
- "PANIC: could not determine iterator for input $type");
+ unless ($stream) {
+ $self->_croak('PANIC: could not determine stream');
}
while ( my ( $k, $v ) = each %initialize ) {
$self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
}
- $self->version($version) if $version;
- $self->_iterator($iterator);
+ $self->_stream($stream);
$self->_spool($spool);
$self->ignore_exit($ignore_exit);
@@ -639,8 +637,8 @@ C<$result> object.
Returns a list of pragmas each of which is a + or - followed by the
pragma name.
-
-=head2 C<comment> methods
+
+=head2 C<commment> methods
if ( $result->is_comment ) { ... }
@@ -717,7 +715,7 @@ line.
my $explanation = $result->explanation;
If a test had either a C<TODO> or C<SKIP> directive, this method will return
-the accompanying explanation, if present.
+the accompanying explantion, if present.
not ok 17 - 'Pigs can fly' # TODO not enough acid
@@ -796,11 +794,7 @@ but had a TODO directive, it will be counted as a passed test.
=cut
-sub passed {
- return @{ $_[0]->{passed} }
- if ref $_[0]->{passed};
- return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed};
-}
+sub passed { @{ shift->{passed} } }
=head3 C<failed>
@@ -827,11 +821,7 @@ regardless of whether or not a TODO directive was found.
=cut
-sub actual_passed {
- return @{ $_[0]->{actual_passed} }
- if ref $_[0]->{actual_passed};
- return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed};
-}
+sub actual_passed { @{ shift->{actual_passed} } }
*actual_ok = \&actual_passed;
=head3 C<actual_ok>
@@ -1053,7 +1043,7 @@ an executable, it returns the exit status of the executable.
Once the parser is done, this will return the wait status. If the parser ran
an executable, it returns the wait status of the executable. Otherwise, this
-merely returns the C<exit> status.
+mererely returns the C<exit> status.
=head2 C<ignore_exit>
@@ -1318,7 +1308,7 @@ sub _make_state_table {
UNPLANNED_AFTER_TEST => {
test => { act => sub { }, continue => 'UNPLANNED' },
plan => { act => sub { }, continue => 'UNPLANNED' },
- yaml => { goto => 'UNPLANNED' },
+ yaml => { goto => 'PLANNED' },
},
);
@@ -1351,23 +1341,23 @@ determine the readiness of this parser.
=cut
-sub get_select_handles { shift->_iterator->get_select_handles }
+sub get_select_handles { shift->_stream->get_select_handles }
sub _grammar {
my $self = shift;
return $self->{_grammar} = shift if @_;
return $self->{_grammar} ||= $self->make_grammar(
- { iterator => $self->_iterator,
- parser => $self,
- version => $self->version
+ { stream => $self->_stream,
+ parser => $self,
+ version => $self->version
}
);
}
sub _iter {
my $self = shift;
- my $iterator = $self->_iterator;
+ my $stream = $self->_stream;
my $grammar = $self->_grammar;
my $spool = $self->_spool;
my $state = 'INIT';
@@ -1404,8 +1394,8 @@ sub _iter {
# Handle end of stream - which means either pop a block or finish
my $end_handler = sub {
- $self->exit( $iterator->exit );
- $self->wait( $iterator->wait );
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
$self->_finish;
return;
};
@@ -1468,7 +1458,7 @@ sub _finish {
$self->end_time( $self->get_time );
# Avoid leaks
- $self->_iterator(undef);
+ $self->_stream(undef);
$self->_grammar(undef);
# If we just delete the iter we won't get a fault if it's recreated.
@@ -1505,17 +1495,6 @@ sub _finish {
}
$self->is_good_plan(0) unless defined $self->is_good_plan;
-
- unless ( $self->parse_errors ) {
- # Optimise storage where possible
- if ( $self->tests_run == @{$self->{passed}} ) {
- $self->{passed} = $self->tests_run;
- }
- if ( $self->tests_run == @{$self->{actual_passed}} ) {
- $self->{actual_passed} = $self->tests_run;
- }
- }
-
return $self;
}
@@ -1553,7 +1532,7 @@ result as its argument.
);
my $aggregator = TAP::Parser::Aggregator->new;
- for my $file ( @test_files ) {
+ foreach my $file ( @test_files ) {
my $parser = TAP::Parser->new(
{
source => $file,
@@ -1656,9 +1635,9 @@ passed instead.
If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
-=head1 BACKWARDS COMPATIBILITY
+=head1 BACKWARDS COMPATABILITY
-The Perl-QA list attempted to ensure backwards compatibility with
+The Perl-QA list attempted to ensure backwards compatability with
L<Test::Harness>. However, there are some minor differences.
=head2 Differences
@@ -1706,7 +1685,7 @@ never run. They're reported as parse failures (tests out of sequence).
If you find you need to provide custom functionality (as you would have using
L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
-designed to be easily plugged-into and/or subclassed.
+designed to be easily subclassed.
Before you start, it's important to know a few things:
@@ -1718,26 +1697,23 @@ All C<TAP::*> objects inherit from L<TAP::Object>.
=item 2
-Many C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
+Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
=item 3
-Note that C<TAP::Parser> is designed to be the central "maker" - ie: it is
-responsible for creating most new objects in the C<TAP::Parser::*> namespace.
+Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
+responsible for creating new objects in the C<TAP::Parser::*> namespace.
This makes it possible for you to have a single point of configuring what
-subclasses should be used, which means that in many cases you'll find
+subclasses should be used, which in turn means that in many cases you'll find
you only need to sub-class one of the parser's components.
-The exception to this rule are I<SourceHandlers> & I<Iterators>, but those are
-both created with customizable I<IteratorFactory>.
-
=item 4
By subclassing, you may end up overriding undocumented methods. That's not
a bad thing per se, but be forewarned that undocumented methods may change
without warning from one release to the next - we cannot guarantee backwards
-compatibility. If any I<documented> method needs changing, it will be
+compatability. If any I<documented> method needs changing, it will be
deprecated first, and changed in a later release.
=back
@@ -1746,41 +1722,28 @@ deprecated first, and changed in a later release.
=head3 Sources
-A TAP parser consumes input from a single I<raw source> of TAP, which could come
-from anywhere (a file, an executable, a database, an IO handle, a URI, etc..).
-The source gets bundled up in a L<TAP::Parser::Source> object which gathers some
-meta data about it. The parser then uses a L<TAP::Parser::IteratorFactory> to
-determine which L<TAP::Parser::SourceHandler> to use to turn the raw source
-into a stream of TAP by way of L</Iterators>.
-
-If you simply want C<TAP::Parser> to handle a new source of TAP you probably
-don't need to subclass C<TAP::Parser> itself. Rather, you'll need to create a
-new L<TAP::Parser::SourceHandler> class, and just plug it into the parser using
-the I<sources> param to L</new>. Before you start writing one, read through
-L<TAP::Parser::IteratorFactory> to get a feel for how the system works first.
-
-If you find you really need to use your own iterator factory you can still do
-so without sub-classing C<TAP::Parser> by setting L</iterator_factory_class>.
-
-If you just need to customize the objects on creation, subclass L<TAP::Parser>
-and override L</make_iterator_factory>.
+A TAP parser consumes input from a I<source>. There are currently two types
+of sources: L<TAP::Parser::Source> for general non-perl commands, and
+L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to
+customize your parser by setting the C<source_class> & C<perl_source_class>
+parameters. See L</new> for more details.
-Note that C<make_source> & C<make_perl_source> have been I<DEPRECATED> and
-are now removed.
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_source> or L</make_perl_source>.
=head3 Iterators
-A TAP parser uses I<iterators> to loop through the I<stream> of TAP read in
-from the I<source> it was given. There are a few types of Iterators available
-by default, all sub-classes of L<TAP::Parser::Iterator>. Choosing which
-iterator to use is the responsibility of the I<iterator factory>, though it
-simply delegates to the I<Source Handler> it uses.
+A TAP parser uses I<iterators> to loop through the I<stream> provided by the
+parser's I<source>. There are quite a few types of Iterators available.
+Choosing which class to use is the responsibility of the I<iterator factory>.
-If you're writing your own L<TAP::Parser::SourceHandler>, you may need to
-create your own iterators too. If so you'll need to subclass
-L<TAP::Parser::Iterator>.
+To create your own iterators you'll have to subclass
+L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll
+need to customize the class used by your parser by setting the
+C<iterator_factory_class> parameter. See L</new> for more details.
-Note that L</make_iterator> has been I<DEPRECATED> and is now removed.
+If you need to customize the objects on creation, subclass L<TAP::Parser> and
+override L</make_iterator>.
=head3 Results
@@ -1811,7 +1774,7 @@ override L</make_result>.
=head3 Grammar
-L<TAP::Parser::Grammar> is the heart of the parser. It tokenizes the TAP
+L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
input I<stream> and produces results. If you need to customize its behaviour
you should probably familiarize yourself with the source first. Enough
lecturing.
@@ -1822,7 +1785,7 @@ C<grammar_class> parameter. See L</new> for more details.
If you need to customize the objects on creation, subclass L<TAP::Parser> and
override L</make_grammar>
-=head1 ACKNOWLEDGMENTS
+=head1 ACKNOWLEDGEMENTS
All of the following have helped. Bug reports, patches, (im)moral
support, or just words of encouragement have all been forthcoming.
@@ -1867,10 +1830,6 @@ support, or just words of encouragement have all been forthcoming.
=item * Alex Vandiver
-=item * Cosimo Streppone
-
-=item * Ville Skyttä
-
=back
=head1 AUTHORS
@@ -1889,10 +1848,6 @@ Steve Purkis <spurkis@cpan.org>
Nicholas Clark <nick@ccl4.org>
-Lee Johnson <notfadeaway at btinternet dot com>
-
-Philippe Bruhat <book@cpan.org>
-
=head1 BUGS
Please report any bugs or feature requests to
@@ -1904,7 +1859,7 @@ progress on your bug as we make changes.
Obviously, bugs which include patches are best. If you prefer, you can
patch against bleed by via anonymous checkout of the latest version:
- git clone git://github.com/Perl-Toolchain-Gang/Test-Harness.git
+ svn checkout http://svn.hexten.net/tapx
=head1 COPYRIGHT & LICENSE
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm
index ee4befd3fa3..10b37ef72a3 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm
@@ -1,10 +1,12 @@
package TAP::Parser::Aggregator;
use strict;
-use warnings;
use Benchmark;
+use vars qw($VERSION @ISA);
-use base 'TAP::Object';
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
=head1 NAME
@@ -12,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
@@ -72,7 +74,7 @@ BEGIN { # install summary methods
$SUMMARY_METHOD_FOR{total} = 'tests_run';
$SUMMARY_METHOD_FOR{planned} = 'tests_planned';
- for my $method ( keys %SUMMARY_METHOD_FOR ) {
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
next if 'total' eq $method;
no strict 'refs';
*$method = sub {
@@ -88,7 +90,7 @@ sub _initialize {
my ($self) = @_;
$self->{parser_for} = {};
$self->{parse_order} = [];
- for my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
$self->{$summary} = 0;
next if 'total' eq $summary;
$self->{"descriptions_for_$summary"} = [];
@@ -173,7 +175,7 @@ sub parsers {
sub _get_parsers {
my ( $self, @descriptions ) = @_;
my @parsers;
- for my $description (@descriptions) {
+ foreach my $description (@descriptions) {
$self->_croak("A parser for ($description) could not be found")
unless exists $self->{parser_for}{$description};
push @parsers => $self->{parser_for}{$description};
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm
index fe1b9adba2e..44f28a0491e 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm
@@ -1,12 +1,13 @@
package TAP::Parser::Grammar;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
+use TAP::Object ();
use TAP::Parser::ResultFactory ();
use TAP::Parser::YAMLish::Reader ();
-use base 'TAP::Object';
+@ISA = qw(TAP::Object);
=head1 NAME
@@ -14,27 +15,27 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
use TAP::Parser::Grammar;
my $grammar = $self->make_grammar({
- iterator => $tap_parser_iterator,
- parser => $tap_parser,
- version => 12,
+ stream => $tap_parser_stream,
+ parser => $tap_parser,
+ version => 12,
});
my $result = $grammar->tokenize;
=head1 DESCRIPTION
-C<TAP::Parser::Grammar> tokenizes lines from a L<TAP::Parser::Iterator> and
-constructs L<TAP::Parser::Result> subclasses to represent the tokens.
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
Do not attempt to use this class directly. It won't make sense. It's mainly
here to ensure that we will be able to have pluggable grammars when TAP is
@@ -48,24 +49,22 @@ parser).
=head3 C<new>
my $grammar = TAP::Parser::Grammar->new({
- iterator => $iterator,
- parser => $parser,
- version => $version,
+ stream => $stream,
+ parser => $parser,
+ version => $version,
});
-Returns L<TAP::Parser> grammar object that will parse the TAP stream from the
-specified iterator. Both C<iterator> and C<parser> are required arguments.
-If C<version> is not set it defaults to C<12> (see L</set_version> for more
-details).
+Returns L<TAP::Parser> grammar object that will parse the specified stream.
+Both C<stream> and C<parser> are required arguments. If C<version> is not set
+it defaults to C<12> (see L</set_version> for more details).
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my ( $self, $args ) = @_;
- $self->{iterator} = $args->{iterator}; # TODO: accessor
- $self->{iterator} ||= $args->{stream}; # deprecated
- $self->{parser} = $args->{parser}; # TODO: accessor
+ $self->{stream} = $args->{stream}; # TODO: accessor
+ $self->{parser} = $args->{parser}; # TODO: accessor
$self->set_version( $args->{version} || 12 );
return $self;
}
@@ -163,7 +162,7 @@ my %language_for;
},
},
bailout => {
- syntax => qr/^\s*Bail out!\s*(.*)/,
+ syntax => qr/^Bail out!\s*(.*)/,
handler => sub {
my ( $self, $line ) = @_;
my $explanation = $1;
@@ -219,7 +218,7 @@ my %language_for;
'13' => {
tokens => \%v13,
setup => sub {
- shift->{iterator}->handle_unicode;
+ shift->{stream}->handle_unicode;
},
},
);
@@ -285,7 +284,7 @@ current line of TAP.
sub tokenize {
my $self = shift;
- my $line = $self->{iterator}->next;
+ my $line = $self->{stream}->next;
unless ( defined $line ) {
delete $self->{parser}; # break circular ref
return;
@@ -293,7 +292,7 @@ sub tokenize {
my $token;
- for my $token_data ( @{ $self->{ordered_tokens} } ) {
+ foreach my $token_data ( @{ $self->{ordered_tokens} } ) {
if ( $line =~ $token_data->{syntax} ) {
my $handler = $token_data->{handler};
$token = $self->$handler($line);
@@ -352,7 +351,7 @@ TAP parsing loop looks similar to the following:
my @tokens;
my $grammar = TAP::Grammar->new;
LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
- for my $type ( $grammar->token_types ) {
+ foreach my $type ( $grammar->token_types ) {
my $syntax = $grammar->syntax_for($type);
if ( $line =~ $syntax ) {
my $handler = $grammar->handler_for($type);
@@ -404,10 +403,7 @@ sub _make_test_token {
my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
return {
ok => $ok,
-
- # forcing this to be an integer (and not a string) reduces memory
- # consumption. RT #84939
- test_num => ( defined $num ? 0 + $num : undef ),
+ test_num => $num,
description => _trim($desc),
directive => ( defined $dir ? uc $dir : '' ),
explanation => _trim($explanation),
@@ -447,7 +443,7 @@ sub _make_yaml_token {
my $yaml = TAP::Parser::YAMLish::Reader->new;
- my $iterator = $self->{iterator};
+ my $stream = $self->{stream};
# Construct a reader that reads from our input stripping leading
# spaces from each line.
@@ -456,7 +452,7 @@ sub _make_yaml_token {
my @extra = ($marker);
my $reader = sub {
return shift @extra if @extra;
- my $line = $iterator->next;
+ my $line = $stream->next;
return $2 if $line =~ $strip;
return;
};
@@ -506,7 +502,7 @@ stream-based protocol. In fact, it's quite legal to have an infinite stream.
For the same reason that we don't apply regexes to streams, we're not using a
formal grammar here. Instead, we parse the TAP in lines.
-For purposes for forward compatibility, any result which does not match the
+For purposes for forward compatability, any result which does not match the
following grammar is currently referred to as
L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm
index 886f5f4656b..09d40bebccb 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm
@@ -1,39 +1,41 @@
package TAP::Parser::Iterator;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Object';
+use TAP::Object ();
+
+@ISA = qw(TAP::Object);
=head1 NAME
-TAP::Parser::Iterator - Base class for TAP source iterators
+TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
+ # see TAP::Parser::IteratorFactory for general usage
+
# to subclass:
+ use vars qw(@ISA);
use TAP::Parser::Iterator ();
- use base 'TAP::Parser::Iterator';
+ @ISA = qw(TAP::Parser::Iterator);
sub _initialize {
# see TAP::Object...
}
- sub next_raw { ... }
- sub wait { ... }
- sub exit { ... }
-
=head1 DESCRIPTION
This is a simple iterator base class that defines L<TAP::Parser>'s iterator
-API. Iterators are typically created from L<TAP::Parser::SourceHandler>s.
+API. See C<TAP::Parser::IteratorFactory> for the preferred way of creating
+iterators.
=head1 METHODS
@@ -154,6 +156,7 @@ There's not much point repeating it here.
L<TAP::Object>,
L<TAP::Parser>,
+L<TAP::Parser::IteratorFactory>,
L<TAP::Parser::Iterator::Array>,
L<TAP::Parser::Iterator::Stream>,
L<TAP::Parser::Iterator::Process>,
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm
index 929b1004585..1513d5b9945 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm
@@ -1,24 +1,29 @@
package TAP::Parser::Iterator::Array;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Parser::Iterator';
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
=head1 NAME
-TAP::Parser::Iterator::Array - Iterator for array-based TAP sources
+TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
use TAP::Parser::Iterator::Array;
my @data = ('foo', 'bar', baz');
my $it = TAP::Parser::Iterator::Array->new(\@data);
@@ -27,8 +32,8 @@ our $VERSION = '3.30';
=head1 DESCRIPTION
This is a simple iterator wrapper for arrays of scalar content, used by
-L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
-won't need to use this module directly.
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
=head1 METHODS
@@ -95,6 +100,7 @@ Originally ripped off from L<Test::Harness>.
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
=cut
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm
index aaf6b6cf61a..a0a5a8ed32e 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm
@@ -1,29 +1,33 @@
package TAP::Parser::Iterator::Process;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
+use TAP::Parser::Iterator ();
use Config;
use IO::Handle;
-use base 'TAP::Parser::Iterator';
+@ISA = 'TAP::Parser::Iterator';
my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
=head1 NAME
-TAP::Parser::Iterator::Process - Iterator for process-based TAP sources
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
use TAP::Parser::Iterator::Process;
my %args = (
command => ['python', 'setup.py', 'test'],
@@ -37,8 +41,8 @@ our $VERSION = '3.30';
=head1 DESCRIPTION
This is a simple iterator wrapper for executing external processes, used by
-L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
-won't need to use this module directly.
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
=head1 METHODS
@@ -76,18 +80,12 @@ Get the exit status for this iterator's process.
=cut
-{
-
- no warnings 'uninitialized';
- # get around a catch22 in the test suite that causes failures on Win32:
- local $SIG{__DIE__} = undef;
- eval { require POSIX; &POSIX::WEXITSTATUS(0) };
- if ($@) {
- *_wait2exit = sub { $_[1] >> 8 };
- }
- else {
- *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
- }
+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+}
+else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
}
sub _use_open3 {
@@ -119,8 +117,6 @@ sub _initialize {
my @command = @{ delete $args->{command} || [] }
or die "Must supply a command to execute";
- $self->{command} = [@command];
-
# Private. Used to frig with chunk size during testing.
my $chunk_size = delete $args->{_chunk_size} || 65536;
@@ -137,7 +133,7 @@ sub _initialize {
# HOTPATCH {{{
my $xclose = \&IPC::Open3::xclose;
- no warnings;
+ local $^W; # no warnings
local *IPC::Open3::xclose = sub {
my $fh = shift;
no strict 'refs';
@@ -157,7 +153,9 @@ sub _initialize {
};
die "Could not execute (@command): $@" if $@;
if ( $] >= 5.006 ) {
- binmode($out, ":crlf");
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
}
}
else {
@@ -373,6 +371,7 @@ Originally ripped off from L<Test::Harness>.
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
=cut
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm
index 9181fc7ae79..c92cbabe089 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm
@@ -1,24 +1,29 @@
package TAP::Parser::Iterator::Stream;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Parser::Iterator';
+use TAP::Parser::Iterator ();
+
+@ISA = 'TAP::Parser::Iterator';
=head1 NAME
-TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
+ # see TAP::Parser::IteratorFactory for preferred usage
+
+ # to use directly:
use TAP::Parser::Iterator::Stream;
open( TEST, 'test.tap' );
my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
@@ -27,8 +32,8 @@ our $VERSION = '3.30';
=head1 DESCRIPTION
This is a simple iterator wrapper for reading from filehandles, used by
-L<TAP::Parser>. Unless you're writing a plugin or subclassing, you probably
-won't need to use this module directly.
+L<TAP::Parser>. Unless you're subclassing, you probably won't need to use
+this module directly.
=head1 METHODS
@@ -101,6 +106,7 @@ Originally ripped off from L<Test::Harness>.
L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Iterator>,
+L<TAP::Parser::IteratorFactory>,
=cut
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm
index 8b75724fd8e..064d7beb167 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm
@@ -1,40 +1,42 @@
package TAP::Parser::IteratorFactory;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use Carp qw( confess );
-use File::Basename qw( fileparse );
+use TAP::Object ();
+use TAP::Parser::Iterator::Array ();
+use TAP::Parser::Iterator::Stream ();
+use TAP::Parser::Iterator::Process ();
-use base 'TAP::Object';
-
-use constant handlers => [];
+@ISA = qw(TAP::Object);
=head1 NAME
-TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use for a given Source
+TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
use TAP::Parser::IteratorFactory;
- my $factory = TAP::Parser::IteratorFactory->new({ %config });
- my $iterator = $factory->make_iterator( $filename );
+ my $factory = TAP::Parser::IteratorFactory->new;
+ my $iter = $factory->make_iterator(\*TEST);
+ my $iter = $factory->make_iterator(\@array);
+ my $iter = $factory->make_iterator(\%hash);
-=head1 DESCRIPTION
+ my $line = $iter->next;
-This is a factory class that takes a L<TAP::Parser::Source> and runs it through all the
-registered L<TAP::Parser::SourceHandler>s to see which one should handle the source.
+=head1 DESCRIPTION
-If you're a plugin author, you'll be interested in how to L</register_handler>s,
-how L</detect_source> works.
+This is a factory class for simple iterator wrappers for arrays, filehandles,
+and hashes. Unless you're subclassing, you probably won't need to use this
+module directly.
=head1 METHODS
@@ -42,296 +44,128 @@ how L</detect_source> works.
=head3 C<new>
-Creates a new factory class:
+Creates a new factory class.
+I<Note:> You currently don't need to instantiate a factory in order to use it.
- my $sf = TAP::Parser::IteratorFactory->new( $config );
-
-C<$config> is optional. If given, sets L</config> and calls L</load_handlers>.
+=head3 C<make_iterator>
-=cut
+Create an iterator. The type of iterator created depends on the arguments to
+the constructor:
-sub _initialize {
- my ( $self, $config ) = @_;
- $self->config( $config || {} )->load_handlers;
- return $self;
-}
+ my $iter = TAP::Parser::Iterator->make_iterator( $filehandle );
-=head3 C<register_handler>
+Creates a I<stream> iterator (see L</make_stream_iterator>).
-Registers a new L<TAP::Parser::SourceHandler> with this factory.
+ my $iter = TAP::Parser::Iterator->make_iterator( $array_reference );
- __PACKAGE__->register_handler( $handler_class );
+Creates an I<array> iterator (see L</make_array_iterator>).
-=head3 C<handlers>
+ my $iter = TAP::Parser::Iterator->make_iterator( $hash_reference );
-List of handlers that have been registered.
+Creates a I<process> iterator (see L</make_process_iterator>).
=cut
-sub register_handler {
- my ( $class, $dclass ) = @_;
-
- confess("$dclass must implement can_handle & make_iterator methods!")
- unless UNIVERSAL::can( $dclass, 'can_handle' )
- && UNIVERSAL::can( $dclass, 'make_iterator' );
-
- my $handlers = $class->handlers;
- push @{$handlers}, $dclass
- unless grep { $_ eq $dclass } @{$handlers};
-
- return $class;
-}
-
-##############################################################################
-
-=head2 Instance Methods
-
-=head3 C<config>
-
- my $cfg = $sf->config;
- $sf->config({ Perl => { %config } });
-
-Chaining getter/setter for the configuration of the available source handlers.
-This is a hashref keyed on handler class whose values contain config to be passed
-onto the handlers during detection & creation. Class names may be fully qualified
-or abbreviated, eg:
-
- # these are equivalent
- $sf->config({ 'TAP::Parser::SourceHandler::Perl' => { %config } });
- $sf->config({ 'Perl' => { %config } });
-
-=cut
+sub make_iterator {
+ my ( $proto, $thing ) = @_;
-sub config {
- my $self = shift;
- return $self->{config} unless @_;
- unless ( 'HASH' eq ref $_[0] ) {
- $self->_croak('Argument to &config must be a hash reference');
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return $proto->make_stream_iterator($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return $proto->make_array_iterator($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return $proto->make_process_iterator($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
}
- $self->{config} = shift;
- return $self;
-}
-
-sub _last_handler {
- my $self = shift;
- return $self->{last_handler} unless @_;
- $self->{last_handler} = shift;
- return $self;
-}
-
-sub _testing {
- my $self = shift;
- return $self->{testing} unless @_;
- $self->{testing} = shift;
- return $self;
}
-##############################################################################
-
-=head3 C<load_handlers>
+=head3 C<make_stream_iterator>
- $sf->load_handlers;
+Make a new stream iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Stream>.
-Loads the handler classes defined in L</config>. For example, given a config:
+=head3 C<make_array_iterator>
- $sf->config({
- MySourceHandler => { some => 'config' },
- });
+Make a new array iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Array>.
-C<load_handlers> will attempt to load the C<MySourceHandler> class by looking in
-C<@INC> for it in this order:
+=head3 C<make_process_iterator>
- TAP::Parser::SourceHandler::MySourceHandler
- MySourceHandler
-
-C<croak>s on error.
+Make a new process iterator and return it. Passes through any arguments given.
+Defaults to a L<TAP::Parser::Iterator::Process>.
=cut
-sub load_handlers {
- my ($self) = @_;
- for my $handler ( keys %{ $self->config } ) {
- my $sclass = $self->_load_handler($handler);
-
- # TODO: store which class we loaded anywhere?
- }
- return $self;
+sub make_stream_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Stream->new(@_);
}
-sub _load_handler {
- my ( $self, $handler ) = @_;
-
- my @errors;
- for my $dclass ( "TAP::Parser::SourceHandler::$handler", $handler ) {
- return $dclass
- if UNIVERSAL::can( $dclass, 'can_handle' )
- && UNIVERSAL::can( $dclass, 'make_iterator' );
-
- eval "use $dclass";
- if ( my $e = $@ ) {
- push @errors, $e;
- next;
- }
-
- return $dclass
- if UNIVERSAL::can( $dclass, 'can_handle' )
- && UNIVERSAL::can( $dclass, 'make_iterator' );
- push @errors,
- "handler '$dclass' does not implement can_handle & make_iterator";
- }
-
- $self->_croak(
- "Cannot load handler '$handler': " . join( "\n", @errors ) );
+sub make_array_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Array->new(@_);
}
-##############################################################################
-
-=head3 C<make_iterator>
-
- my $iterator = $src_factory->make_iterator( $source );
-
-Given a L<TAP::Parser::Source>, finds the most suitable L<TAP::Parser::SourceHandler>
-to use to create a L<TAP::Parser::Iterator> (see L</detect_source>). Dies on error.
-
-=cut
-
-sub make_iterator {
- my ( $self, $source ) = @_;
-
- $self->_croak('no raw source defined!') unless defined $source->raw;
-
- $source->config( $self->config )->assemble_meta;
-
- # is the raw source already an object?
- return $source->raw
- if ( $source->meta->{is_object}
- && UNIVERSAL::isa( $source->raw, 'TAP::Parser::SourceHandler' ) );
-
- # figure out what kind of source it is
- my $sd_class = $self->detect_source($source);
- $self->_last_handler($sd_class);
-
- return if $self->_testing;
-
- # create it
- my $iterator = $sd_class->make_iterator($source);
-
- return $iterator;
+sub make_process_iterator {
+ my $proto = shift;
+ TAP::Parser::Iterator::Process->new(@_);
}
-=head3 C<detect_source>
-
-Given a L<TAP::Parser::Source>, detects what kind of source it is and
-returns I<one> L<TAP::Parser::SourceHandler> (the most confident one). Dies
-on error.
-
-The detection algorithm works something like this:
-
- for (@registered_handlers) {
- # ask them how confident they are about handling this source
- $confidence{$handler} = $handler->can_handle( $source )
- }
- # choose the most confident handler
-
-Ties are handled by choosing the first handler.
-
-=cut
-
-sub detect_source {
- my ( $self, $source ) = @_;
-
- confess('no raw source ref defined!') unless defined $source->raw;
-
- # find a list of handlers that can handle this source:
- my %handlers;
- for my $dclass ( @{ $self->handlers } ) {
- my $confidence = $dclass->can_handle($source);
-
- # warn "handler: $dclass: $confidence\n";
- $handlers{$dclass} = $confidence if $confidence;
- }
-
- if ( !%handlers ) {
+1;
- # use Data::Dump qw( pp );
- # warn pp( $meta );
+=head1 SUBCLASSING
- # error: can't detect source
- my $raw_source_short = substr( ${ $source->raw }, 0, 50 );
- confess("Cannot detect source of '$raw_source_short'!");
- return;
- }
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
- # if multiple handlers can handle it, choose the most confident one
- my @handlers = (
- map {$_}
- sort { $handlers{$a} cmp $handlers{$b} }
- keys %handlers
- );
-
- # this is really useful for debugging handlers:
- if ( $ENV{TAP_HARNESS_SOURCE_FACTORY_VOTES} ) {
- warn(
- "votes: ",
- join( ', ', map {"$_: $handlers{$_}"} @handlers ),
- "\n"
- );
- }
+There are a few things to bear in mind when creating your own
+C<ResultFactory>:
- # return 1st
- return pop @handlers;
-}
+=over 4
-1;
+=item 1
-__END__
+The factory itself is never instantiated (this I<may> change in the future).
+This means that C<_initialize> is never called.
-=head1 SUBCLASSING
-
-Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+=back
=head2 Example
-If we've done things right, you'll probably want to write a new source,
-rather than sub-classing this (see L<TAP::Parser::SourceHandler> for that).
-
-But in case you find the need to...
-
package MyIteratorFactory;
use strict;
+ use vars '@ISA';
- use base 'TAP::Parser::IteratorFactory';
+ use MyStreamIterator;
+ use TAP::Parser::IteratorFactory;
- # override source detection algorithm
- sub detect_source {
- my ($self, $raw_source_ref, $meta) = @_;
- # do detective work, using $meta and whatever else...
+ @ISA = qw( TAP::Parser::IteratorFactory );
+
+ # override stream iterator
+ sub make_stream_iterator {
+ my $proto = shift;
+ MyStreamIterator->new(@_);
}
1;
-=head1 AUTHORS
-
-Steve Purkis
-
=head1 ATTRIBUTION
Originally ripped off from L<Test::Harness>.
-Moved out of L<TAP::Parser> & converted to a factory class to support
-extensible TAP source detective work by Steve Purkis.
-
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
-L<TAP::Parser::SourceHandler>,
-L<TAP::Parser::SourceHandler::File>,
-L<TAP::Parser::SourceHandler::Perl>,
-L<TAP::Parser::SourceHandler::RawTAP>,
-L<TAP::Parser::SourceHandler::Handle>,
-L<TAP::Parser::SourceHandler::Executable>
+L<TAP::Parser::Iterator>,
+L<TAP::Parser::Iterator::Array>,
+L<TAP::Parser::Iterator::Stream>,
+L<TAP::Parser::Iterator::Process>,
=cut
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm
index 65cd46de13e..2e5d9296888 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm
@@ -1,27 +1,28 @@
package TAP::Parser::Multiplexer;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
use IO::Select;
-
-use base 'TAP::Object';
+use TAP::Object ();
use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
use constant IS_VMS => $^O eq 'VMS';
use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+@ISA = 'TAP::Object';
+
=head1 NAME
TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result.pm
index eaad1d2f41b..b01e95c5d9a 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result.pm
@@ -1,9 +1,11 @@
package TAP::Parser::Result;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Object';
+use TAP::Object ();
+
+@ISA = 'TAP::Object';
BEGIN {
@@ -24,15 +26,15 @@ TAP::Parser::Result - Base class for TAP::Parser output objects
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
- # abstract class - not meant to be used directly
+ # abstract class - not meany to be used directly
# see TAP::Parser::ResultFactory for preferred usage
# directly:
@@ -272,8 +274,9 @@ subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
package MyResult;
use strict;
+ use vars '@ISA';
- use base 'TAP::Parser::Result';
+ @ISA = 'TAP::Parser::Result';
# register with the factory:
TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm
index 2ae35d6e603..3e42f4110fd 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm
@@ -1,9 +1,10 @@
package TAP::Parser::Result::Bailout;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
=head1 NAME
@@ -11,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm
index d69ec5189c2..1e9ba13c5f2 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm
@@ -1,9 +1,10 @@
package TAP::Parser::Result::Comment;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
=head1 NAME
@@ -11,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm
index d85243c9766..67c01df200d 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm
@@ -1,9 +1,10 @@
package TAP::Parser::Result::Plan;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
=head1 NAME
@@ -11,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm
index 1479e8836cd..3eb62b3322b 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm
@@ -1,9 +1,10 @@
package TAP::Parser::Result::Pragma;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
=head1 NAME
@@ -11,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm
index 749f26cbe2b..11cf302de6a 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm
@@ -1,9 +1,12 @@
package TAP::Parser::Result::Test;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
=head1 NAME
@@ -11,11 +14,11 @@ TAP::Parser::Result::Test - Test result token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
@@ -98,7 +101,7 @@ sub directive { shift->{directive} }
my $explanation = $result->explanation;
If a test had either a C<TODO> or C<SKIP> directive, this method will return
-the accompanying explanation, if present.
+the accompanying explantion, if present.
not ok 17 - 'Pigs can fly' # TODO not enough acid
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm
index 3e1a6112271..52e19585d9a 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm
@@ -1,9 +1,12 @@
package TAP::Parser::Result::Unknown;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
=head1 NAME
@@ -11,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm
index 8b08e33d063..b97681eb065 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm
@@ -1,9 +1,10 @@
package TAP::Parser::Result::Version;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
=head1 NAME
@@ -11,11 +12,11 @@ TAP::Parser::Result::Version - TAP syntax version token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm
index a6f86e3c46d..ada3ae445bb 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm
@@ -1,9 +1,10 @@
package TAP::Parser::Result::YAML;
use strict;
-use warnings;
-use base 'TAP::Parser::Result';
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
=head1 NAME
@@ -11,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm
index 65d31d25367..46d0df29dbd 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm
@@ -1,8 +1,9 @@
package TAP::Parser::ResultFactory;
use strict;
-use warnings;
+use vars qw($VERSION @ISA %CLASS_FOR);
+use TAP::Object ();
use TAP::Parser::Result::Bailout ();
use TAP::Parser::Result::Comment ();
use TAP::Parser::Result::Plan ();
@@ -12,7 +13,7 @@ use TAP::Parser::Result::Unknown ();
use TAP::Parser::Result::Version ();
use TAP::Parser::Result::YAML ();
-use base 'TAP::Object';
+@ISA = 'TAP::Object';
##############################################################################
@@ -29,11 +30,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head2 DESCRIPTION
@@ -82,7 +83,8 @@ a completely new type, eg:
# create a custom result type:
package MyResult;
use strict;
- use base 'TAP::Parser::Result';
+ use vars qw(@ISA);
+ @ISA = 'TAP::Parser::Result';
# register with the factory:
TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
@@ -94,16 +96,18 @@ Your custom type should then be picked up automatically by the L<TAP::Parser>.
=cut
-our %CLASS_FOR = (
- plan => 'TAP::Parser::Result::Plan',
- pragma => 'TAP::Parser::Result::Pragma',
- test => 'TAP::Parser::Result::Test',
- comment => 'TAP::Parser::Result::Comment',
- bailout => 'TAP::Parser::Result::Bailout',
- version => 'TAP::Parser::Result::Version',
- unknown => 'TAP::Parser::Result::Unknown',
- yaml => 'TAP::Parser::Result::YAML',
-);
+BEGIN {
+ %CLASS_FOR = (
+ plan => 'TAP::Parser::Result::Plan',
+ pragma => 'TAP::Parser::Result::Pragma',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+ );
+}
sub class_for {
my ( $class, $type ) = @_;
@@ -162,10 +166,12 @@ Of course, it's up to you to decide whether or not to ignore them.
package MyResultFactory;
use strict;
+ use vars '@ISA';
use MyResult;
+ use TAP::Parser::ResultFactory;
- use base 'TAP::Parser::ResultFactory';
+ @ISA = qw( TAP::Parser::ResultFactory );
# force all results to be 'MyResult'
sub class_for {
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm
index 7c5cedf7edc..f1817093af0 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm
@@ -1,8 +1,7 @@
package TAP::Parser::Scheduler;
use strict;
-use warnings;
-
+use vars qw($VERSION);
use Carp;
use TAP::Parser::Scheduler::Job;
use TAP::Parser::Scheduler::Spinner;
@@ -13,11 +12,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
@@ -31,98 +30,9 @@ our $VERSION = '3.30';
=head3 C<new>
- my $sched = TAP::Parser::Scheduler->new(tests => \@tests);
- my $sched = TAP::Parser::Scheduler->new(
- tests => [ ['t/test_name.t','Test Description'], ... ],
- rules => \%rules,
- );
-
-Given 'tests' and optional 'rules' as input, returns a new
-C<TAP::Parser::Scheduler> object. Each member of C<@tests> should be either a
-a test file name, or a two element arrayref, where the first element is a test
-file name, and the second element is a test description. By default, we'll use
-the test name as the description.
-
-The optional C<rules> attribute provides direction on which tests should be run
-in parallel and which should be run sequentially. If no rule data structure is
-provided, a default data structure is used which makes every test eligible to
-be run in parallel:
-
- { par => '**' },
-
-The rules data structure is documented more in the next section.
-
-=head2 Rules data structure
-
-The "C<rules>" data structure is the the heart of the scheduler. It allows you
-to express simple rules like "run all tests in sequence" or "run all tests in
-parallel except these five tests.". However, the rules structure also supports
-glob-style pattern matching and recursive definitions, so you can also express
-arbitarily complicated patterns.
-
-The rule must only have one top level key: either 'par' for "parallel" or 'seq'
-for "sequence".
-
-Values must be either strings with possible glob-style matching, or arrayrefs
-of strings or hashrefs which follow this pattern recursively.
-
-Every element in an arrayref directly below a 'par' key is eligible to be run
-in parallel, while vavalues directly below a 'seq' key must be run in sequence.
-
-=head3 Rules examples
-
-Here are some examples:
-
- # All tests be run in parallel (the default rule)
- { par => '**' },
-
- # Run all tests in sequence, except those starting with "p"
- { par => 't/p*.t' },
-
- # Run all tests in parallel, except those starting with "p"
- {
- seq => [
- { seq => 't/p*.t' },
- { par => '**' },
- ],
- }
-
- # Run some startup tests in sequence, then some parallel tests than some
- # teardown tests in sequence.
- {
- seq => [
- { seq => 't/startup/*.t' },
- { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], }
- { seq => 't/shutdown/*.t' },
- ],
- },
+ my $sched = TAP::Parser::Scheduler->new;
-
-=head3 Rules resolution
-
-=over4
-
-=item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one.
-
-=item * "First match wins". The first rule that matches a test will be the one that applies.
-
-=item * Any test which does not match a rule will be run in sequence at the end of the run.
-
-=item * The existence of a rule does not imply selecting a test. You must still specify the tests to run.
-
-=item * Specifying a rule to allow tests to run in parallel does not make the run in parallel. You still need specify the number of parallel C<jobs> in your Harness object.
-
-=back
-
-=head3 Glob-style pattern matching for rules
-
-We implement our own glob-style pattern matching. Here are the patterns it supports:
-
- ** is any number of characters, including /, within a pathname
- * is zero or more characters within a filename/directory name
- ? is exactly one character within a filename/directory name
- {foo,bar,baz} is any of foo, bar or baz.
- \ is an escape character
+Returns a new C<TAP::Parser::Scheduler> object.
=cut
@@ -160,9 +70,6 @@ sub new {
sub _set_rules {
my ( $self, $rules, $tests ) = @_;
-
- # Convert all incoming tests to job objects.
- # If no test description is provided use the file name as the description.
my @tests = map { TAP::Parser::Scheduler::Job->new(@$_) }
map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @$tests;
my $schedule = $self->_rule_clause( $rules, \@tests );
@@ -278,8 +185,6 @@ sub _expand {
return @match;
}
-=head2 Instance Methods
-
=head3 C<get_all>
Get a list of all remaining tests.
@@ -302,9 +207,9 @@ sub _gather {
=head3 C<get_job>
-Return the next available job as L<TAP::Parser::Scheduler::Job> object or
-C<undef> if none are available. Returns a L<TAP::Parser::Scheduler::Spinner> if
-the scheduler still has pending jobs but none are available to run right now.
+Return the next available job or C<undef> if none are available. Returns
+a C<TAP::Parser::Scheduler::Spinner> if the scheduler still has pending
+jobs but none are available to run right now.
=cut
@@ -326,7 +231,7 @@ sub get_job {
sub _not_empty {
my $ar = shift;
return 1 unless 'ARRAY' eq ref $ar;
- for (@$ar) {
+ foreach (@$ar) {
return 1 if _not_empty($_);
}
return;
@@ -376,50 +281,9 @@ sub _find_next_job {
=head3 C<as_string>
Return a human readable representation of the scheduling tree.
-For example:
-
- my @tests = (qw{
- t/startup/foo.t
- t/shutdown/foo.t
-
- t/a/foo.t t/b/foo.t t/c/foo.t t/d/foo.t
- });
- my $sched = TAP::Parser::Scheduler->new(
- tests => \@tests,
- rules => {
- seq => [
- { seq => 't/startup/*.t' },
- { par => ['t/a/*.t','t/b/*.t','t/c/*.t'] },
- { seq => 't/shutdown/*.t' },
- ],
- },
- );
-
-Produces:
-
- par:
- seq:
- par:
- seq:
- par:
- seq:
- 't/startup/foo.t'
- par:
- seq:
- 't/a/foo.t'
- seq:
- 't/b/foo.t'
- seq:
- 't/c/foo.t'
- par:
- seq:
- 't/shutdown/foo.t'
- 't/d/foo.t'
-
=cut
-
sub as_string {
my $self = shift;
return $self->_as_string( $self->{schedule} );
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm
index 6375a7b8786..7ab68f9f673 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm
@@ -1,7 +1,7 @@
package TAP::Parser::Scheduler::Job;
use strict;
-use warnings;
+use vars qw($VERSION);
use Carp;
=head1 NAME
@@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
@@ -31,11 +31,10 @@ Represents a single test 'job'.
=head3 C<new>
my $job = TAP::Parser::Scheduler::Job->new(
- $filename, $description
+ $name, $desc
);
-Given the filename and description of a test as scalars, returns a new
-L<TAP::Parser::Scheduler::Job> object.
+Returns a new C<TAP::Parser::Scheduler::Job> object.
=cut
@@ -48,14 +47,9 @@ sub new {
}, $class;
}
-=head2 Instance Methods
-
=head3 C<on_finish>
- $self->on_finish(\&method).
-
-Register a closure to be called when this job is destroyed. The callback
-will be passed the C<TAP::Parser::Scheduler::Job> object as it's only argument.
+Register a closure to be called when this job is destroyed.
=cut
@@ -66,10 +60,7 @@ sub on_finish {
=head3 C<finish>
- $self->finish;
-
-Called when a job is complete to unlock it. If a callback has been registered
-with C<on_finish>, it calls it. Otherwise, it does nothing.
+Called when a job is complete to unlock it.
=cut
@@ -80,15 +71,6 @@ sub finish {
}
}
-=head2 Attributes
-
- $self->filename;
- $self->description;
- $self->context;
-
-These are all "getters" which return the data set for these attributes during object construction.
-
-
=head3 C<filename>
=head3 C<description>
@@ -114,8 +96,6 @@ sub as_array_ref {
=head3 C<is_spinner>
- $self->is_spinner;
-
Returns false indicating that this is a real job rather than a
'spinner'. Spinners are returned when the scheduler still has pending
jobs but can't (because of locking) return one right now.
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm
index f590ea58f04..10af5e33697 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm
@@ -1,7 +1,7 @@
package TAP::Parser::Scheduler::Spinner;
use strict;
-use warnings;
+use vars qw($VERSION);
use Carp;
=head1 NAME
@@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job.
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
@@ -34,14 +34,12 @@ return a real job.
my $job = TAP::Parser::Scheduler::Spinner->new;
-Ignores any arguments and returns a new C<TAP::Parser::Scheduler::Spinner> object.
+Returns a new C<TAP::Parser::Scheduler::Spinner> object.
=cut
sub new { bless {}, shift }
-=head2 Instance Methods
-
=head3 C<is_spinner>
Returns true indicating that is a 'spinner' job. Spinners are returned
@@ -52,10 +50,4 @@ return one right now.
sub is_spinner {1}
-=head1 SEE ALSO
-
-L<TAP::Parser::Scheduler>, L<TAP::Parser::Scheduler::Job>
-
-=cut
-
1;
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Source.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Source.pm
index 0e2da09f644..9263e9e5442 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Source.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/Source.pm
@@ -1,51 +1,37 @@
package TAP::Parser::Source;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use File::Basename qw( fileparse );
-use base 'TAP::Object';
+use TAP::Object ();
+use TAP::Parser::IteratorFactory ();
-use constant BLK_SIZE => 512;
+@ISA = qw(TAP::Object);
+
+# Causes problem on MacOS and shouldn't be necessary anyway
+#$SIG{CHLD} = sub { wait };
=head1 NAME
-TAP::Parser::Source - a TAP source & meta data about it
+TAP::Parser::Source - Stream output from some source
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
=head1 SYNOPSIS
use TAP::Parser::Source;
my $source = TAP::Parser::Source->new;
- $source->raw( \'reference to raw TAP source' )
- ->config( \%config )
- ->merge( $boolean )
- ->switches( \@switches )
- ->test_args( \@args )
- ->assemble_meta;
-
- do { ... } if $source->meta->{is_file};
- # see assemble_meta for a full list of data available
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
=head1 DESCRIPTION
-A TAP I<source> is something that produces a stream of TAP for the parser to
-consume, such as an executable file, a text file, an archive, an IO handle, a
-database, etc. C<TAP::Parser::Source>s encapsulate these I<raw> sources, and
-provide some useful meta data about them. They are used by
-L<TAP::Parser::SourceHandler>s, which do whatever is required to produce &
-capture a stream of TAP from the I<raw> source, and package it up in a
-L<TAP::Parser::Iterator> for the parser to consume.
-
-Unless you're writing a new L<TAP::Parser::SourceHandler>, a plugin or
-subclassing L<TAP::Parser>, you probably won't need to use this module directly.
+Takes a command and hopefully returns a stream from it.
=head1 METHODS
@@ -62,9 +48,10 @@ Returns a new C<TAP::Parser::Source> object.
# new() implementation supplied by TAP::Object
sub _initialize {
- my ($self) = @_;
- $self->meta( {} );
- $self->config( {} );
+ my ( $self, $args ) = @_;
+ $self->{switches} = [];
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
return $self;
}
@@ -72,310 +59,115 @@ sub _initialize {
=head2 Instance Methods
-=head3 C<raw>
-
- my $raw = $source->raw;
- $source->raw( $some_value );
-
-Chaining getter/setter for the raw TAP source. This is a reference, as it may
-contain large amounts of data (eg: raw TAP).
-
-=head3 C<meta>
-
- my $meta = $source->meta;
- $source->meta({ %some_value });
-
-Chaining getter/setter for meta data about the source. This defaults to an
-empty hashref. See L</assemble_meta> for more info.
-
-=head3 C<has_meta>
-
-True if the source has meta data.
-
-=head3 C<config>
-
- my $config = $source->config;
- $source->config({ %some_value });
-
-Chaining getter/setter for the source's configuration, if any has been provided
-by the user. How it's used is up to you. This defaults to an empty hashref.
-See L</config_for> for more info.
-
-=head3 C<merge>
-
- my $merge = $source->merge;
- $source->config( $bool );
-
-Chaining getter/setter for the flag that dictates whether STDOUT and STDERR
-should be merged (where appropriate). Defaults to undef.
-
-=head3 C<switches>
-
- my $switches = $source->switches;
- $source->config([ @switches ]);
+=head3 C<source>
-Chaining getter/setter for the list of command-line switches that should be
-passed to the source (where appropriate). Defaults to undef.
+ my $source = $source->source;
+ $source->source(['./some_prog some_test_file']);
-=head3 C<test_args>
+ # or
+ $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
- my $test_args = $source->test_args;
- $source->config([ @test_args ]);
-
-Chaining getter/setter for the list of command-line arguments that should be
-passed to the source (where appropriate). Defaults to undef.
+Getter/setter for the source. The source should generally consist of an array
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>,
+should return a filehandle which returns successive rows of TAP. C<croaks> if
+it doesn't get an arrayref.
=cut
-sub raw {
+sub source {
my $self = shift;
- return $self->{raw} unless @_;
- $self->{raw} = shift;
+ return $self->{source} unless @_;
+ unless ( 'ARRAY' eq ref $_[0] ) {
+ $self->_croak('Argument to &source must be an array reference');
+ }
+ $self->{source} = shift;
return $self;
}
-sub meta {
- my $self = shift;
- return $self->{meta} unless @_;
- $self->{meta} = shift;
- return $self;
-}
+##############################################################################
-sub has_meta {
- return scalar %{ shift->meta } ? 1 : 0;
-}
+=head3 C<get_stream>
-sub config {
- my $self = shift;
- return $self->{config} unless @_;
- $self->{config} = shift;
- return $self;
-}
+ my $stream = $source->get_stream;
-sub merge {
- my $self = shift;
- return $self->{merge} unless @_;
- $self->{merge} = shift;
- return $self;
-}
+Returns a L<TAP::Parser::Iterator> stream of the output generated by executing
+C<source>. C<croak>s if there was no command found.
-sub switches {
- my $self = shift;
- return $self->{switches} unless @_;
- $self->{switches} = shift;
- return $self;
-}
-
-sub test_args {
- my $self = shift;
- return $self->{test_args} unless @_;
- $self->{test_args} = shift;
- return $self;
-}
-
-=head3 C<assemble_meta>
-
- my $meta = $source->assemble_meta;
-
-Gathers meta data about the L</raw> source, stashes it in L</meta> and returns
-it as a hashref. This is done so that the L<TAP::Parser::SourceHandler>s don't
-have to repeat common checks. Currently this includes:
-
- is_scalar => $bool,
- is_hash => $bool,
- is_array => $bool,
-
- # for scalars:
- length => $n
- has_newlines => $bool
-
- # only done if the scalar looks like a filename
- is_file => $bool,
- is_dir => $bool,
- is_symlink => $bool,
- file => {
- # only done if the scalar looks like a filename
- basename => $string, # including ext
- dir => $string,
- ext => $string,
- lc_ext => $string,
- # system checks
- exists => $bool,
- stat => [ ... ], # perldoc -f stat
- empty => $bool,
- size => $n,
- text => $bool,
- binary => $bool,
- read => $bool,
- write => $bool,
- execute => $bool,
- setuid => $bool,
- setgid => $bool,
- sticky => $bool,
- is_file => $bool,
- is_dir => $bool,
- is_symlink => $bool,
- # only done if the file's a symlink
- lstat => [ ... ], # perldoc -f lstat
- # only done if the file's a readable text file
- shebang => $first_line,
- }
-
- # for arrays:
- size => $n,
+Must be passed an object that implements a C<make_iterator> method.
+Typically this is a TAP::Parser instance.
=cut
-sub assemble_meta {
- my ($self) = @_;
-
- return $self->meta if $self->has_meta;
-
- my $meta = $self->meta;
- my $raw = $self->raw;
-
- # rudimentary is object test - if it's blessed it'll
- # inherit from UNIVERSAL
- $meta->{is_object} = UNIVERSAL::isa( $raw, 'UNIVERSAL' ) ? 1 : 0;
-
- if ( $meta->{is_object} ) {
- $meta->{class} = ref($raw);
- }
- else {
- my $ref = lc( ref($raw) );
- $meta->{"is_$ref"} = 1;
- }
+sub get_stream {
+ my ( $self, $factory ) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
- if ( $meta->{is_scalar} ) {
- my $source = $$raw;
- $meta->{length} = length($$raw);
- $meta->{has_newlines} = $$raw =~ /\n/ ? 1 : 0;
-
- # only do file checks if it looks like a filename
- if ( !$meta->{has_newlines} and $meta->{length} < 1024 ) {
- my $file = {};
- $file->{exists} = -e $source ? 1 : 0;
- if ( $file->{exists} ) {
- $meta->{file} = $file;
-
- # avoid extra system calls (see `perldoc -f -X`)
- $file->{stat} = [ stat(_) ];
- $file->{empty} = -z _ ? 1 : 0;
- $file->{size} = -s _;
- $file->{text} = -T _ ? 1 : 0;
- $file->{binary} = -B _ ? 1 : 0;
- $file->{read} = -r _ ? 1 : 0;
- $file->{write} = -w _ ? 1 : 0;
- $file->{execute} = -x _ ? 1 : 0;
- $file->{setuid} = -u _ ? 1 : 0;
- $file->{setgid} = -g _ ? 1 : 0;
- $file->{sticky} = -k _ ? 1 : 0;
-
- $meta->{is_file} = $file->{is_file} = -f _ ? 1 : 0;
- $meta->{is_dir} = $file->{is_dir} = -d _ ? 1 : 0;
-
- # symlink check requires another system call
- $meta->{is_symlink} = $file->{is_symlink}
- = -l $source ? 1 : 0;
- if ( $file->{is_symlink} ) {
- $file->{lstat} = [ lstat(_) ];
- }
-
- # put together some common info about the file
- ( $file->{basename}, $file->{dir}, $file->{ext} )
- = map { defined $_ ? $_ : '' }
- fileparse( $source, qr/\.[^.]*/ );
- $file->{lc_ext} = lc( $file->{ext} );
- $file->{basename} .= $file->{ext} if $file->{ext};
-
- if ( !$file->{is_dir} && $file->{read} ) {
- eval { $file->{shebang} = $self->shebang($$raw); };
- if ( my $e = $@ ) {
- warn $e;
- }
- }
- }
+ return $factory->make_iterator(
+ { command => \@command,
+ merge => $self->merge
}
- }
- elsif ( $meta->{is_array} ) {
- $meta->{size} = $#$raw + 1;
- }
- elsif ( $meta->{is_hash} ) {
- ; # do nothing
- }
-
- return $meta;
+ );
}
-=head3 C<shebang>
-
-Get the shebang line for a script file.
-
- my $shebang = TAP::Parser::Source->shebang( $some_script );
+sub _get_command { return @{ shift->source || [] } }
-May be called as a class method
-
-=cut
+##############################################################################
-{
+=head3 C<merge>
- # Global shebang cache.
- my %shebang_for;
+ my $merge = $source->merge;
- sub _read_shebang {
- my ( $class, $file ) = @_;
- open my $fh, '<', $file or die "Can't read $file: $!\n";
+Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
- # Might be a binary file - so read a fixed number of bytes.
- my $got = read $fh, my ($buf), BLK_SIZE;
- defined $got or die "I/O error: $!\n";
- return $1 if $buf =~ /(.*)/;
- return;
- }
+=cut
- sub shebang {
- my ( $class, $file ) = @_;
- $shebang_for{$file} = $class->_read_shebang($file)
- unless exists $shebang_for{$file};
- return $shebang_for{$file};
- }
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
}
-=head3 C<config_for>
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
- my $config = $source->config_for( $class );
+1;
-Returns L</config> for the $class given. Class names may be fully qualified
-or abbreviated, eg:
+=head1 SUBCLASSING
- # these are equivalent
- $source->config_for( 'Perl' );
- $source->config_for( 'TAP::Parser::SourceHandler::Perl' );
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
-If a fully qualified $class is given, its abbreviated version is checked first.
+=head2 Example
-=cut
+ package MyRubySource;
-sub config_for {
- my ( $self, $class ) = @_;
- my ($abbrv_class) = ( $class =~ /(?:\:\:)?(\w+)$/ );
- my $config = $self->config->{$abbrv_class} || $self->config->{$class};
- return $config;
-}
+ use strict;
+ use vars '@ISA';
-1;
-
-__END__
+ use Carp qw( croak );
+ use TAP::Parser::Source;
-=head1 AUTHORS
+ @ISA = qw( TAP::Parser::Source );
-Steve Purkis.
+ # expect $source->(['mytest.rb', 'cmdline', 'args']);
+ sub source {
+ my ($self, $args) = @_;
+ my ($rb_file) = @$args;
+ croak("error: Ruby file '$rb_file' not found!") unless (-f $rb_file);
+ return $self->SUPER::source(['/usr/bin/ruby', @$args]);
+ }
=head1 SEE ALSO
L<TAP::Object>,
L<TAP::Parser>,
-L<TAP::Parser::IteratorFactory>,
-L<TAP::Parser::SourceHandler>
+L<TAP::Parser::Source::Perl>,
=cut
+
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm
index 8a61a4bfd92..524d7dca8df 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm
@@ -1,11 +1,12 @@
package TAP::Parser::YAMLish::Reader;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Object';
+use TAP::Object ();
-our $VERSION = '3.30';
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
# TODO:
# Handle blessed object syntax
@@ -269,7 +270,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
=head1 VERSION
-Version 3.30
+Version 3.17
=head1 SYNOPSIS
@@ -293,7 +294,7 @@ C<TAP::Parser::YAMLish::Reader> object.
=head3 C<read>
- my $got = $reader->read($iterator);
+ my $got = $reader->read($stream);
Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
represents.
@@ -318,7 +319,7 @@ L<http://use.perl.org/~Alias/journal/29427>
=head1 COPYRIGHT
-Copyright 2007-2011 Andy Armstrong.
+Copyright 2007-2008 Andy Armstrong.
Portions copyright 2006-2008 Adam Kennedy.
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm
index 811c190d124..ed81f6d8191 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm
@@ -1,11 +1,12 @@
package TAP::Parser::YAMLish::Writer;
use strict;
-use warnings;
+use vars qw($VERSION @ISA);
-use base 'TAP::Object';
+use TAP::Object ();
-our $VERSION = '3.30';
+@ISA = 'TAP::Object';
+$VERSION = '3.17';
my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
@@ -146,7 +147,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data
=head1 VERSION
-Version 3.30
+Version 3.17
=head1 SYNOPSIS
@@ -242,7 +243,7 @@ L<http://use.perl.org/~Alias/journal/29427>
=head1 COPYRIGHT
-Copyright 2007-2011 Andy Armstrong.
+Copyright 2007-2008 Andy Armstrong.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
diff --git a/gnu/usr.bin/perl/cpan/Test-Harness/lib/Test/Harness.pm b/gnu/usr.bin/perl/cpan/Test-Harness/lib/Test/Harness.pm
index aa54574b44c..eba3c5efc4a 100644
--- a/gnu/usr.bin/perl/cpan/Test-Harness/lib/Test/Harness.pm
+++ b/gnu/usr.bin/perl/cpan/Test-Harness/lib/Test/Harness.pm
@@ -1,28 +1,41 @@
package Test::Harness;
-use 5.006;
+require 5.00405;
use strict;
-use warnings;
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS => ( $^O eq 'VMS' );
-use TAP::Harness ();
-use TAP::Parser::Aggregator ();
-use TAP::Parser::Source ();
-use TAP::Parser::SourceHandler::Perl ();
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
-use Text::ParseWords qw(shellwords);
+use TAP::Parser::Utils qw( split_shell );
use Config;
-use base 'Exporter';
+use Exporter;
+
+# TODO: Emulate at least some of these
+use vars qw(
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
+ $IgnoreExit
+);
# $ML $Last_ML_Print
BEGIN {
eval q{use Time::HiRes 'time'};
- our $has_time_hires = !$@;
+ $has_time_hires = !$@;
}
=head1 NAME
@@ -31,11 +44,11 @@ Test::Harness - Run Perl standard test scripts with statistics
=head1 VERSION
-Version 3.30
+Version 3.17
=cut
-our $VERSION = '3.30';
+$VERSION = '3.17';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
@@ -52,17 +65,18 @@ END {
delete $ENV{HARNESS_VERSION};
}
-our @EXPORT = qw(&runtests);
-our @EXPORT_OK = qw(&execute_tests $verbose $switches);
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw(&execute_tests $verbose $switches);
-our $Verbose = $ENV{HARNESS_VERBOSE} || 0;
-our $Debug = $ENV{HARNESS_DEBUG} || 0;
-our $Switches = '-w';
-our $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Switches = '-w';
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
$Columns--; # Some shells have trouble with a full line of text.
-our $Timer = $ENV{HARNESS_TIMER} || 0;
-our $Color = $ENV{HARNESS_COLOR} || 0;
-our $IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+$IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
=head1 SYNOPSIS
@@ -104,8 +118,8 @@ one of the messages in the DIAGNOSTICS section.
sub _has_taint {
my $test = shift;
- return TAP::Parser::SourceHandler::Perl->get_taint(
- TAP::Parser::Source->shebang($test) );
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
}
sub _aggregate {
@@ -118,7 +132,7 @@ sub _aggregate {
_aggregate_tests( $harness, $aggregate, @tests );
}
-# Make sure the child sees all the extra junk in @INC
+# Make sure the child seens all the extra junk in @INC
sub _apply_extra_INC {
my $harness = shift;
@@ -193,7 +207,7 @@ sub _new_harness {
my $sub_args = shift || {};
my ( @lib, @switches );
- my @opt = map { shellwords($_) } grep { defined } $Switches, $ENV{HARNESS_PERL_SWITCHES};
+ my @opt = split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} );
while ( my $opt = shift @opt ) {
if ( $opt =~ /^ -I (.*) $ /x ) {
push @lib, length($1) ? $1 : shift @opt;
@@ -211,7 +225,7 @@ sub _new_harness {
my $args = {
timer => $Timer,
- directives => our $Directives,
+ directives => $Directives,
lib => \@lib,
switches => \@switches,
color => $Color,
@@ -222,7 +236,6 @@ sub _new_harness {
$args->{stdout} = $sub_args->{out}
if exists $sub_args->{out};
- my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness';
if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
for my $opt ( split /:/, $env_opt ) {
if ( $opt =~ /^j(\d*)$/ ) {
@@ -231,23 +244,13 @@ sub _new_harness {
elsif ( $opt eq 'c' ) {
$args->{color} = 1;
}
- elsif ( $opt =~ m/^f(.*)$/ ) {
- my $fmt = $1;
- $fmt =~ s/-/::/g;
- $args->{formatter_class} = $fmt;
- }
- elsif ( $opt =~ m/^a(.*)$/ ) {
- my $archive = $1;
- $class = "TAP::Harness::Archive";
- $args->{archive} = $archive;
- }
else {
die "Unknown HARNESS_OPTIONS item: $opt\n";
}
}
}
- return TAP::Harness->_construct( $class, $args );
+ return TAP::Harness->new($args);
}
# Get the parts of @INC which are changed from the stock list AND
@@ -265,7 +268,7 @@ sub _filtered_inc {
elsif (IS_WIN32) {
# Lose any trailing backslashes in the Win32 paths
- s/[\\\/]+$// for @inc;
+ s/[\\\/]+$// foreach @inc;
}
my @default_inc = _default_inc();
@@ -302,7 +305,7 @@ sub _filtered_inc {
my $perl = $ENV{HARNESS_PERL} || $^X;
# Avoid using -l for the benefit of Perl 6
- chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` );
+ chomp( @inc = `$perl -e "print join qq[\\n], \@INC, q[]"` );
return @inc;
}
}
@@ -503,17 +506,6 @@ This is the version of C<Test::Harness>.
=over 4
-=item C<HARNESS_PERL_SWITCHES>
-
-Setting this adds perl command line switches to each test file run.
-
-For example, C<HARNESS_PERL_SWITCHES=-T> will turn on taint mode.
-C<HARNESS_PERL_SWITCHES=-MDevel::Cover> will run C<Devel::Cover> for
-each test.
-
-C<-w> is always set. You can turn this off in the test with C<BEGIN {
-$^W = 0 }>.
-
=item C<HARNESS_TIMER>
Setting this to true will make the harness display the number of
@@ -536,39 +528,15 @@ Provide additional options to the harness. Currently supported options are:
Run <n> (default 9) parallel jobs.
-=item C<< c >>
-
-Try to color output. See L<TAP::Formatter::Base/"new">.
-
-=item C<< a<file.tgz> >>
+=item C<< f >>
-Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to
-C<file.tgz>
-
-=item C<< fPackage-With-Dashes >>
-
-Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS>
-is seperated by C<:>, we use C<-> instead.
+Use forked parallelism.
=back
Multiple options may be separated by colons:
- HARNESS_OPTIONS=j9:c make test
-
-=item C<HARNESS_SUBCLASS>
-
-Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
-
-=item C<HARNESS_SUMMARY_COLOR_SUCCESS>
-
-Determines the L<Term::ANSIColor> for the summary in case it is successful.
-This color defaults to C<'green'>.
-
-=item C<HARNESS_SUMMARY_COLOR_FAIL>
-
-Determines the L<Term::ANSIColor> for the failure in case it is successful.
-This color defaults to C<'red'>.
+ HARNESS_OPTIONS=j9:f make test
=back
@@ -578,9 +546,10 @@ Normally when a Perl program is run in taint mode the contents of the
C<PERL5LIB> environment variable do not appear in C<@INC>.
Because C<PERL5LIB> is often used during testing to add build
-directories to C<@INC> C<Test::Harness> passes the names of any
-directories found in C<PERL5LIB> as -I switches. The net effect of this
-is that C<PERL5LIB> is honoured even in taint mode.
+directories to C<@INC> C<Test::Harness> (actually
+L<TAP::Parser::Source::Perl>) passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even in taint mode.
=head1 SEE ALSO
@@ -609,7 +578,7 @@ module is based) has this attribution:
=head1 LICENCE AND COPYRIGHT
-Copyright (c) 2007-2011, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
diff --git a/gnu/usr.bin/perl/cpan/Test/lib/Test.pm b/gnu/usr.bin/perl/cpan/Test/lib/Test.pm
index 108bc10a167..6ab54ab5601 100644
--- a/gnu/usr.bin/perl/cpan/Test/lib/Test.pm
+++ b/gnu/usr.bin/perl/cpan/Test/lib/Test.pm
@@ -20,7 +20,7 @@ sub _reset_globals {
$planned = 0;
}
-$VERSION = '1.26';
+$VERSION = '1.25_02';
require Exporter;
@ISA=('Exporter');
diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm
index 9bac7077e70..0bdc65fed1e 100644
--- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm
+++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm
@@ -19,7 +19,7 @@ require Exporter;
);
%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
-$VERSION = "0.40";
+$VERSION = "0.35";
sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
@@ -579,16 +579,16 @@ tag ("ar") exists.
Examples:
- alternate_language_tags('no-bok') is ('nb')
- alternate_language_tags('nb') is ('no-bok')
- alternate_language_tags('he') is ('iw')
- alternate_language_tags('iw') is ('he')
- alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
- alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
- alternate_language_tags('en') is ()
- alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
- alternate_language_tags('x-klikitat') is ('i-klikitat')
- alternate_language_tags('i-klikitat') is ('x-klikitat')
+ alternate_language_tags('no-bok') is ('nb')
+ alternate_language_tags('nb') is ('no-bok')
+ alternate_language_tags('he') is ('iw')
+ alternate_language_tags('iw') is ('he')
+ alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
+ alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
+ alternate_language_tags('en') is ()
+ alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
+ alternate_language_tags('x-klikitat') is ('i-klikitat')
+ alternate_language_tags('i-klikitat') is ('x-klikitat')
This function returns empty-list if given anything other than a formally
valid language tag.
@@ -678,7 +678,7 @@ sub alternate_language_tags {
# My guesses at Slavic intelligibility:
([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian
- ([qw(sr hr bs)]) x 2, # Serbian, Croatian, Bosnian
+ 'sr' => 'hr', 'hr' => 'sr', # Serb + Croat
'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
@@ -844,17 +844,17 @@ language tags with their ASCII characters shifted into Plane 14.
* L<I18N::LangTags::List|I18N::LangTags::List>
-* RFC 3066, C<http://www.ietf.org/rfc/rfc3066.txt>, "Tags for the
+* RFC 3066, C<ftp://ftp.isi.edu/in-notes/rfc3066.txt>, "Tags for the
Identification of Languages". (Obsoletes RFC 1766)
-* RFC 2277, C<http://www.ietf.org/rfc/rfc2277.txt>, "IETF Policy on
+* RFC 2277, C<ftp://ftp.isi.edu/in-notes/rfc2277.txt>, "IETF Policy on
Character Sets and Languages".
-* RFC 2231, C<http://www.ietf.org/rfc/rfc2231.txt>, "MIME Parameter
+* RFC 2231, C<ftp://ftp.isi.edu/in-notes/rfc2231.txt>, "MIME Parameter
Value and Encoded Word Extensions: Character Sets, Languages, and
Continuations".
-* RFC 2482, C<http://www.ietf.org/rfc/rfc2482.txt>,
+* RFC 2482, C<ftp://ftp.isi.edu/in-notes/rfc2482.txt>,
"Language Tagging in Unicode Plain Text".
* Locale::Codes, in
@@ -862,7 +862,7 @@ C<http://www.perl.com/CPAN/modules/by-module/Locale/>
* ISO 639-2, "Codes for the representation of names of languages",
including two-letter and three-letter codes,
-C<http://www.loc.gov/standards/iso639-2/php/code_list.php>
+C<http://www.loc.gov/standards/iso639-2/langcodes.html>
* The IANA list of registered languages (hopefully up-to-date),
C<http://www.iana.org/assignments/language-tags>
diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm
index f13d5460b32..87280b7b511 100644
--- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm
+++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm
@@ -11,7 +11,7 @@ use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
# define the constant 'DEBUG' at compile-time
-$VERSION = "1.05";
+$VERSION = "1.04";
@ISA = ();
use I18N::LangTags qw(alternate_language_tags locale2language_tag);
@@ -136,7 +136,6 @@ sub _try_use { # Basically a wrapper around "require Modulename"
my $module = $_[0]; # ASSUME sane module name!
{ no strict 'refs';
- no warnings 'once';
return($tried{$module} = 1)
if %{$module . "::Lexicon"} or @{$module . "::ISA"};
# weird case: we never use'd it, but there it is!
diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm
index 786d7b89bb8..5494bea21ed 100644
--- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm
+++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm
@@ -4,7 +4,7 @@ package I18N::LangTags::List;
# Time-stamp: "2004-10-06 23:26:21 ADT"
use strict;
use vars qw(%Name %Is_Disrec $Debug $VERSION);
-$VERSION = '0.39';
+$VERSION = '0.35';
# POD at the end.
#----------------------------------------------------------------------
diff --git a/gnu/usr.bin/perl/dist/IO/IO.pm b/gnu/usr.bin/perl/dist/IO/IO.pm
index ba89f0c8e6c..61e957c2fcc 100644
--- a/gnu/usr.bin/perl/dist/IO/IO.pm
+++ b/gnu/usr.bin/perl/dist/IO/IO.pm
@@ -7,7 +7,7 @@ use Carp;
use strict;
use warnings;
-our $VERSION = "1.31";
+our $VERSION = "1.25_02";
XSLoader::load 'IO', $VERSION;
sub import {
@@ -32,8 +32,8 @@ IO - load various IO modules
=head1 SYNOPSIS
- use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File
- use IO; # DEPRECATED
+ use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File
+ use IO; # DEPRECATED
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm
index 7326d7823d4..cce392c2ce3 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm
@@ -19,14 +19,14 @@ use File::stat;
use File::Spec;
@ISA = qw(Tie::Hash Exporter);
-$VERSION = "1.10";
+$VERSION = "1.07";
$VERSION = eval $VERSION;
@EXPORT_OK = qw(DIR_UNLINK);
sub DIR_UNLINK () { 1 }
sub new {
- @_ >= 1 && @_ <= 2 or croak 'usage: IO::Dir->new([DIRNAME])';
+ @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]';
my $class = shift;
my $dh = gensym;
if (@_) {
@@ -186,7 +186,7 @@ argument which, if given, C<new> will pass to C<open>
=back
The following methods are wrappers for the directory related functions built
-into perl (the trailing 'dir' has been removed from the names). See L<perlfunc>
+into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
for details of these functions.
=over 4
@@ -237,7 +237,7 @@ L<File::stat>
=head1 AUTHOR
Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perlbug@perl.org>.
+bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm
index 8b29bac2210..d33d090d0b2 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm
@@ -10,25 +10,25 @@ IO::File - supply object methods for filehandles
use IO::File;
- $fh = IO::File->new();
+ $fh = new IO::File;
if ($fh->open("< file")) {
print <$fh>;
$fh->close;
}
- $fh = IO::File->new("> file");
+ $fh = new IO::File "> file";
if (defined $fh) {
print $fh "bar\n";
$fh->close;
}
- $fh = IO::File->new("file", "r");
+ $fh = new IO::File "file", "r";
if (defined $fh) {
print <$fh>;
undef $fh; # automatically closes the file
}
- $fh = IO::File->new("file", O_WRONLY|O_APPEND);
+ $fh = new IO::File "file", O_WRONLY|O_APPEND;
if (defined $fh) {
print $fh "corge\n";
@@ -131,12 +131,13 @@ use Carp;
use Symbol;
use SelectSaver;
use IO::Seekable;
+use File::Spec;
require Exporter;
@ISA = qw(IO::Handle IO::Seekable Exporter);
-$VERSION = "1.16";
+$VERSION = "1.14";
@EXPORT = @IO::Seekable::EXPORT;
@@ -156,7 +157,7 @@ sub new {
my $type = shift;
my $class = ref($type) || $type || "IO::File";
@_ >= 0 && @_ <= 3
- or croak "usage: $class->new([FILENAME [,MODE [,PERMS]]])";
+ or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]";
my $fh = $class->SUPER::new();
if (@_) {
$fh->open(@_)
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm
index aebf74e4c02..2f1f1b423bc 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm
@@ -8,13 +8,13 @@ IO::Handle - supply object methods for I/O handles
use IO::Handle;
- $io = IO::Handle->new();
+ $io = new IO::Handle;
if ($io->fdopen(fileno(STDIN),"r")) {
print $io->getline;
$io->close;
}
- $io = IO::Handle->new();
+ $io = new IO::Handle;
if ($io->fdopen(fileno(STDOUT),"w")) {
$io->print("Some text\n");
}
@@ -139,12 +139,9 @@ guaranteed.
=item $io->write ( BUF, LEN [, OFFSET ] )
-This C<write> is somewhat like C<write> found in C, in that it is the
+This C<write> is like C<write> found in C, that is it is the
opposite of read. The wrapper for the perl C<write> function is
-called C<format_write>. However, whilst the C C<write> function returns
-the number of bytes written, this C<write> function simply returns true
-if successful (like C<print>). A more C-like C<write> is C<syswrite>
-(see above).
+called C<format_write>.
=item $io->error
@@ -271,7 +268,7 @@ use IO (); # Load the XS module
require Exporter;
@ISA = qw(Exporter);
-$VERSION = "1.35";
+$VERSION = "1.28";
$VERSION = eval $VERSION;
@EXPORT_OK = qw(
@@ -312,25 +309,14 @@ $VERSION = eval $VERSION;
sub new {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
- if (@_ != 1) {
- # Since perl will automatically require IO::File if needed, but
- # also initialises IO::File's @ISA as part of the core we must
- # ensure IO::File is loaded if IO::Handle is. This avoids effect-
- # ively "half-loading" IO::File.
- if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) {
- require IO::File;
- shift;
- return IO::File::->new(@_);
- }
- croak "usage: $class->new()";
- }
+ @_ == 1 or croak "usage: new $class";
my $io = gensym;
bless $io, $class;
}
sub new_from_fd {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
- @_ == 3 or croak "usage: $class->new_from_fd(FD, MODE)";
+ @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
my $io = gensym;
shift;
IO::Handle::fdopen($io, @_)
@@ -433,14 +419,14 @@ sub say {
print $this @_;
}
-# Special XS wrapper to make them inherit lexical hints from the caller.
-_create_getline_subs( <<'END' ) or die $@;
sub getline {
@_ == 1 or croak 'usage: $io->getline()';
my $this = shift;
return scalar <$this>;
}
+*gets = \&getline; # deprecated
+
sub getlines {
@_ == 1 or croak 'usage: $io->getlines()';
wantarray or
@@ -448,10 +434,6 @@ sub getlines {
my $this = shift;
return <$this>;
}
-1; # return true for error checking
-END
-
-*gets = \&getline; # deprecated
sub truncate {
@_ == 2 or croak 'usage: $io->truncate(LEN)';
@@ -621,11 +603,11 @@ sub ioctl {
return ioctl($io, $op, $_[2]);
}
-# this sub is for compatibility with older releases of IO that used
-# a sub called constant to determine if a constant existed -- GMB
+# this sub is for compatability with older releases of IO that used
+# a sub called constant to detemine if a constant existed -- GMB
#
# The SEEK_* and _IO?BF constants were the only constants at that time
-# any new code should just check defined(&CONSTANT_NAME)
+# any new code should just chech defined(&CONSTANT_NAME)
sub constant {
no strict 'refs';
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm
index 684069f4b7e..827cc48bfcd 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm
@@ -14,12 +14,12 @@ our($VERSION);
use Carp;
use Symbol;
-$VERSION = "1.15";
+$VERSION = "1.13";
sub new {
my $type = shift;
my $class = ref($type) || $type || "IO::Pipe";
- @_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])";
+ @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
my $me = bless gensym(), $class;
@@ -166,7 +166,7 @@ IO::Pipe - supply object methods for pipes
use IO::Pipe;
- $pipe = IO::Pipe->new();
+ $pipe = new IO::Pipe;
if($pid = fork()) { # Parent
$pipe->reader();
@@ -184,7 +184,7 @@ IO::Pipe - supply object methods for pipes
or
- $pipe = IO::Pipe->new();
+ $pipe = new IO::Pipe;
$pipe->reader(qw(ls -l));
@@ -246,7 +246,7 @@ L<IO::Handle>
=head1 AUTHOR
Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perlbug@perl.org>.
+bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm
index 47f1a135595..e7fb0135069 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm
@@ -13,7 +13,7 @@ use Exporter ();
our(@ISA, @EXPORT_OK, @EXPORT, $VERSION);
@ISA = qw(Exporter);
-$VERSION = "0.09";
+$VERSION = "0.07";
@EXPORT = qw( POLLIN
POLLOUT
@@ -140,7 +140,7 @@ IO::Poll - Object interface to system poll call
use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP);
- $poll = IO::Poll->new();
+ $poll = new IO::Poll;
$poll->mask($input_handle => POLLIN);
$poll->mask($output_handle => POLLOUT);
@@ -198,7 +198,7 @@ L<poll(2)>, L<IO::Handle>, L<IO::Select>
=head1 AUTHOR
Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perlbug@perl.org>.
+bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm
index 994f8966ab6..fc05fe70e9c 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm
@@ -11,7 +11,7 @@ use warnings::register;
use vars qw($VERSION @ISA);
require Exporter;
-$VERSION = "1.22";
+$VERSION = "1.17";
@ISA = qw(Exporter); # This is only so we can do version checking
@@ -74,9 +74,9 @@ sub _update
foreach $f (@_)
{
my $fn = $vec->_fileno($f);
+ next unless defined $fn;
+ my $i = $fn + FIRST_FD;
if ($add) {
- next unless defined $fn;
- my $i = $fn + FIRST_FD;
if (defined $vec->[$i]) {
$vec->[$i] = $f; # if array rest might be different, so we update
next;
@@ -85,25 +85,10 @@ sub _update
vec($bits, $fn, 1) = 1;
$vec->[$i] = $f;
} else { # remove
- if ( ! defined $fn ) { # remove if fileno undef'd
- $fn = 0;
- for my $fe (@{$vec}[FIRST_FD .. $#$vec]) {
- if (defined($fe) && $fe == $f) {
- $vec->[FD_COUNT]--;
- $fe = undef;
- vec($bits, $fn, 1) = 0;
- last;
- }
- ++$fn;
- }
- }
- else {
- my $i = $fn + FIRST_FD;
- next unless defined $vec->[$i];
- $vec->[FD_COUNT]--;
- vec($bits, $fn, 1) = 0;
- $vec->[$i] = undef;
- }
+ next unless defined $vec->[$i];
+ $vec->[FD_COUNT]--;
+ vec($bits, $fn, 1) = 0;
+ $vec->[$i] = undef;
}
$count++;
}
@@ -361,8 +346,8 @@ listening for more connections on a listen socket
use IO::Select;
use IO::Socket;
- $lsn = IO::Socket::INET->new(Listen => 1, LocalPort => 8080);
- $sel = IO::Select->new( $lsn );
+ $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+ $sel = new IO::Select( $lsn );
while(@ready = $sel->can_read) {
foreach $fh (@ready) {
@@ -384,7 +369,7 @@ listening for more connections on a listen socket
=head1 AUTHOR
Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perlbug@perl.org>.
+bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm
index c78aeecc1a0..6d4f6ab6123 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm
@@ -1,4 +1,3 @@
-
# IO::Socket.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
@@ -24,7 +23,7 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
@ISA = qw(IO::Handle);
-$VERSION = "1.38";
+$VERSION = "1.31";
@EXPORT_OK = qw(sockatmark);
@@ -119,29 +118,16 @@ sub connect {
my $sel = new IO::Select $sock;
undef $!;
- my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
- if(@$e[0]) {
- # Windows return from select after the timeout in case of
- # WSAECONNREFUSED(10061) if exception set is not used.
- # This behavior is different from Linux.
- # Using the exception
- # set we now emulate the behavior in Linux
- # - Karthik Rajagopalan
- $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
- $@ = "connect: $err";
- }
- elsif(!@$w[0]) {
+ if (!$sel->can_write($timeout)) {
$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
$@ = "connect: timeout";
}
elsif (!connect($sock,$addr) &&
- not ($!{EISCONN} || ($^O eq 'MSWin32' &&
- ($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
+ not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32'))
) {
# Some systems refuse to re-connect() to
# an already open socket and set errno to EISCONN.
- # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
- # EINVAL (22) (5.19.4 onwards).
+ # Windows sets errno to WSAEINVAL (10022)
$err = $!;
$@ = "connect: $!";
}
@@ -169,7 +155,7 @@ sub blocking {
my $sock = shift;
return $sock->SUPER::blocking(@_)
- if $^O ne 'MSWin32' && $^O ne 'VMS';
+ if $^O ne 'MSWin32';
# Windows handles blocking differently
#
@@ -251,8 +237,6 @@ sub accept {
$peer = accept($new,$sock)
or return;
- ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
-
return wantarray ? ($new, $peer)
: $new;
}
@@ -353,27 +337,18 @@ sub timeout {
sub sockdomain {
@_ == 1 or croak 'usage: $sock->sockdomain()';
my $sock = shift;
- if (!defined(${*$sock}{'io_socket_domain'})) {
- my $addr = $sock->sockname();
- ${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
- if (defined($addr));
- }
${*$sock}{'io_socket_domain'};
}
sub socktype {
@_ == 1 or croak 'usage: $sock->socktype()';
my $sock = shift;
- ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
- if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
${*$sock}{'io_socket_type'}
}
sub protocol {
@_ == 1 or croak 'usage: $sock->protocol()';
my($sock) = @_;
- ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
- if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
${*$sock}{'io_socket_proto'};
}
@@ -499,23 +474,8 @@ C<use> declaration will fail at compile time.
=item connected
-If the socket is in a connected state, the peer address is returned. If the
-socket is not in a connected state, undef is returned.
-
-Note that connected() considers a half-open TCP socket to be "in a connected
-state". Specifically, connected() does not distinguish between the
-B<ESTABLISHED> and B<CLOSE-WAIT> TCP states; it returns the peer address,
-rather than undef, in either case. Thus, in general, connected() cannot
-be used to reliably learn whether the peer has initiated a graceful shutdown
-because in most cases (see below) the local TCP state machine remains in
-B<CLOSE-WAIT> until the local application calls shutdown() or close();
-only at that point does connected() return undef.
-
-The "in most cases" hedge is because local TCP state machine behavior may
-depend on the peer's socket options. In particular, if the peer socket has
-SO_LINGER enabled with a zero timeout, then the peer's close() will generate
-a RST segment, upon receipt of which the local TCP transitions immediately to
-B<CLOSED>, and in that state, connected() I<will> return undef.
+If the socket is in a connected state the peer address is returned.
+If the socket is not in a connected state then undef will be returned.
=item protocol
@@ -557,12 +517,6 @@ value returned.
=back
-=head1 LIMITATIONS
-
-On some systems, for an IO::Socket object created with new_from_fd(),
-or created with accept() from such an object, the protocol(),
-sockdomain() and socktype() methods may return undef.
-
=head1 SEE ALSO
L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
@@ -570,7 +524,7 @@ L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>
=head1 AUTHOR
Graham Barr. atmark() by Lincoln Stein. Currently maintained by the
-Perl Porters. Please report all bugs to <perlbug@perl.org>.
+Perl Porters. Please report all bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm
index 7a1694733b5..2f0e5d1d7a6 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm
@@ -15,7 +15,7 @@ use Exporter;
use Errno;
@ISA = qw(IO::Socket);
-$VERSION = "1.35";
+$VERSION = "1.31";
my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
@@ -50,7 +50,7 @@ sub _get_proto_number {
return undef unless defined $name;
return $proto_number{$name} if exists $proto_number{$name};
- my @proto = eval { getprotobyname($name) };
+ my @proto = getprotobyname($name);
return undef unless @proto;
_cache_proto(@proto);
@@ -62,7 +62,7 @@ sub _get_proto_name {
return undef unless defined $num;
return $proto_name{$num} if exists $proto_name{$num};
- my @proto = eval { getprotobynumber($num) };
+ my @proto = getprotobynumber($num);
return undef unless @proto;
_cache_proto(@proto);
@@ -338,28 +338,26 @@ In addition to the key-value pairs accepted by L<IO::Socket>,
C<IO::Socket::INET> provides.
- PeerAddr Remote host address <hostname>[:<port>]
- PeerHost Synonym for PeerAddr
- PeerPort Remote port or service <service>[(<no>)] | <no>
- LocalAddr Local host bind address hostname[:port]
- LocalHost Synonym for LocalAddr
- LocalPort Local host bind port <service>[(<no>)] | <no>
- Proto Protocol name (or number) "tcp" | "udp" | ...
- Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
- Listen Queue size for listen
- ReuseAddr Set SO_REUSEADDR before binding
- Reuse Set SO_REUSEADDR before binding (deprecated,
- prefer ReuseAddr)
- ReusePort Set SO_REUSEPORT before binding
- Broadcast Set SO_BROADCAST before binding
- Timeout Timeout value for various operations
- MultiHomed Try all addresses for multi-homed hosts
- Blocking Determine if connection will be blocking mode
+ PeerAddr Remote host address <hostname>[:<port>]
+ PeerHost Synonym for PeerAddr
+ PeerPort Remote port or service <service>[(<no>)] | <no>
+ LocalAddr Local host bind address hostname[:port]
+ LocalHost Synonym for LocalAddr
+ LocalPort Local host bind port <service>[(<no>)] | <no>
+ Proto Protocol name (or number) "tcp" | "udp" | ...
+ Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
+ Listen Queue size for listen
+ ReuseAddr Set SO_REUSEADDR before binding
+ Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
+ ReusePort Set SO_REUSEPORT before binding
+ Broadcast Set SO_BROADCAST before binding
+ Timeout Timeout value for various operations
+ MultiHomed Try all addresses for multi-homed hosts
+ Blocking Determine if connection will be blocking mode
If C<Listen> is defined then a listen socket is created, else if the
socket type, which is derived from the protocol, is SOCK_STREAM then
-connect() is called. If the C<Listen> argument is given, but false,
-the queue size will be set to 5.
+connect() is called.
Although it is not illegal, the use of C<MultiHomed> on a socket
which is in non-blocking mode is of little use. This is because the
@@ -399,13 +397,12 @@ Examples:
$sock = IO::Socket::INET->new('127.0.0.1:25');
- $sock = IO::Socket::INET->new(
- PeerPort => 9999,
- PeerAddr => inet_ntoa(INADDR_BROADCAST),
- Proto => udp,
- LocalAddr => 'localhost',
- Broadcast => 1 )
- or die "Can't bind : $@\n";
+ $sock = IO::Socket::INET->new(PeerPort => 9999,
+ PeerAddr => inet_ntoa(INADDR_BROADCAST),
+ Proto => udp,
+ LocalAddr => 'localhost',
+ Broadcast => 1 )
+ or die "Can't bind : $@\n";
NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
@@ -456,7 +453,7 @@ L<Socket>, L<IO::Socket>
=head1 AUTHOR
Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perlbug@perl.org>.
+bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm
index 30b8f74eb05..baa092ba1fb 100644
--- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm
+++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm
@@ -12,7 +12,7 @@ use IO::Socket;
use Carp;
@ISA = qw(IO::Socket);
-$VERSION = "1.26";
+$VERSION = "1.23";
$VERSION = eval $VERSION;
IO::Socket::UNIX->register_domain( AF_UNIX );
@@ -74,28 +74,6 @@ IO::Socket::UNIX - Object interface for AF_UNIX domain sockets
use IO::Socket::UNIX;
- my $SOCK_PATH = "$ENV{HOME}/unix-domain-socket-test.sock";
-
- # Server:
- my $server = IO::Socket::UNIX->new(
- Type => SOCK_STREAM(),
- Local => $SOCK_PATH,
- Listen => 1,
- );
-
- my $count = 1;
- while (my $conn = $server->accept()) {
- $conn->print("Hello " . ($count++) . "\n");
- }
-
- # Client:
- my $client = IO::Socket::UNIX->new(
- Type => SOCK_STREAM(),
- Peer => $SOCK_PATH,
- );
-
- # Now read and write from $client
-
=head1 DESCRIPTION
C<IO::Socket::UNIX> provides an object interface to creating and using sockets
@@ -118,12 +96,18 @@ C<IO::Socket::UNIX> provides.
Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
Local Path to local fifo
Peer Path to peer fifo
- Listen Queue size for listen
+ Listen Create a listen socket
If the constructor is only passed a single argument, it is assumed to
be a C<Peer> specification.
-If the C<Listen> argument is given, but false, the queue size will be set to 5.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+
+As of VERSION 1.18 all IO::Socket objects have autoflush turned on
+by default. This was not the case with earlier releases.
+
+ NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
=back
@@ -148,7 +132,7 @@ L<Socket>, L<IO::Socket>
=head1 AUTHOR
Graham Barr. Currently maintained by the Perl Porters. Please report all
-bugs to <perlbug@perl.org>.
+bugs to <perl5-porters@perl.org>.
=head1 COPYRIGHT
diff --git a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm
index c2bd723e91b..1bfbbc9bba4 100644
--- a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm
+++ b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm
@@ -1,33 +1,16 @@
-
package Locale::Maketext;
use strict;
use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
$USE_LITERALS $MATCH_SUPERS_TIGHTLY);
use Carp ();
-use I18N::LangTags ();
-use I18N::LangTags::Detect ();
+use I18N::LangTags 0.30 ();
#--------------------------------------------------------------------------
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
# define the constant 'DEBUG' at compile-time
-# turn on utf8 if we have it (this is what GutsLoader.pm used to do essentially )
-# use if (exists $INC{'utf8.pm'} || eval 'use utf8'), 'utf8';
-BEGIN {
-
- # if we have it || we can load it
- if ( exists $INC{'utf8.pm'} || eval { local $SIG{'__DIE__'};require utf8; } ) {
- utf8->import();
- DEBUG and warn " utf8 on for _compile()\n";
- }
- else {
- DEBUG and warn " utf8 not available for _compile() ($INC{'utf8.pm'})\n$@\n";
- }
-}
-
-
-$VERSION = '1.25';
+$VERSION = '1.14';
@ISA = ();
$MATCH_SUPERS = 1;
@@ -148,7 +131,8 @@ sub failure_handler_auto {
$handle->{'failure_lex'} ||= {};
my $lex = $handle->{'failure_lex'};
- my $value ||= ($lex->{$phrase} ||= $handle->_compile($phrase));
+ my $value;
+ $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
# Dumbly copied from sub maketext:
return ${$value} if ref($value) eq 'SCALAR';
@@ -160,11 +144,12 @@ sub failure_handler_auto {
# If we make it here, there was an exception thrown in the
# call to $value, and so scream:
if($@) {
+ my $err = $@;
# pretty up the error message
- $@ =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
+ $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
{\n in bracket code [compiled line $1],}s;
#$err =~ s/\n?$/\n/s;
- Carp::croak "Error in maketexting \"$phrase\":\n$@ as used";
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
# Rather unexpected, but suppose that the sub tried calling
# a method that didn't exist.
}
@@ -194,54 +179,34 @@ sub maketext {
my($handle, $phrase) = splice(@_,0,2);
Carp::confess('No handle/phrase') unless (defined($handle) && defined($phrase));
- # backup $@ in case it's still being used in the calling code.
- # If no failures, we'll re-set it back to what it was later.
- my $at = $@;
- # Copy @_ case one of its elements is $@.
- @_ = @_;
+ # Don't interefere with $@ in case that's being interpolated into the msg.
+ local $@;
# Look up the value:
my $value;
- if (exists $handle->{'_external_lex_cache'}{$phrase}) {
- DEBUG and warn "* Using external lex cache version of \"$phrase\"\n";
- $value = $handle->{'_external_lex_cache'}{$phrase};
- }
- else {
- foreach my $h_r (
- @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
- ) {
- DEBUG and warn "* Looking up \"$phrase\" in $h_r\n";
- if(exists $h_r->{$phrase}) {
- DEBUG and warn " Found \"$phrase\" in $h_r\n";
- unless(ref($value = $h_r->{$phrase})) {
- # Nonref means it's not yet compiled. Compile and replace.
- if ($handle->{'use_external_lex_cache'}) {
- $value = $handle->{'_external_lex_cache'}{$phrase} = $handle->_compile($value);
- }
- else {
- $value = $h_r->{$phrase} = $handle->_compile($value);
- }
- }
- last;
- }
- # extending packages need to be able to localize _AUTO and if readonly can't "local $h_r->{'_AUTO'} = 1;"
- # but they can "local $handle->{'_external_lex_cache'}{'_AUTO'} = 1;"
- elsif($phrase !~ m/^_/s and ($handle->{'use_external_lex_cache'} ? ( exists $handle->{'_external_lex_cache'}{'_AUTO'} ? $handle->{'_external_lex_cache'}{'_AUTO'} : $h_r->{'_AUTO'} ) : $h_r->{'_AUTO'})) {
- # it's an auto lex, and this is an autoable key!
- DEBUG and warn " Automaking \"$phrase\" into $h_r\n";
- if ($handle->{'use_external_lex_cache'}) {
- $value = $handle->{'_external_lex_cache'}{$phrase} = $handle->_compile($phrase);
- }
- else {
- $value = $h_r->{$phrase} = $handle->_compile($phrase);
- }
- last;
+ foreach my $h_r (
+ @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
+ ) {
+ DEBUG and warn "* Looking up \"$phrase\" in $h_r\n";
+ if(exists $h_r->{$phrase}) {
+ DEBUG and warn " Found \"$phrase\" in $h_r\n";
+ unless(ref($value = $h_r->{$phrase})) {
+ # Nonref means it's not yet compiled. Compile and replace.
+ $value = $h_r->{$phrase} = $handle->_compile($value);
}
- DEBUG>1 and print " Not found in $h_r, nor automakable\n";
- # else keep looking
+ last;
+ }
+ elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
+ # it's an auto lex, and this is an autoable key!
+ DEBUG and warn " Automaking \"$phrase\" into $h_r\n";
+
+ $value = $h_r->{$phrase} = $handle->_compile($phrase);
+ last;
}
+ DEBUG>1 and print " Not found in $h_r, nor automakable\n";
+ # else keep looking
}
unless(defined($value)) {
@@ -250,12 +215,10 @@ sub maketext {
DEBUG and warn "WARNING0: maketext fails looking for <$phrase>\n";
my $fail;
if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
- $@ = $at; # Put $@ back in case we altered it along the way.
return &{$fail}($handle, $phrase, @_);
# If it ever returns, it should return a good value.
}
else { # It's a method name
- $@ = $at; # Put $@ back in case we altered it along the way.
return $handle->$fail($phrase, @_);
# If it ever returns, it should return a good value.
}
@@ -266,14 +229,8 @@ sub maketext {
}
}
- if(ref($value) eq 'SCALAR'){
- $@ = $at; # Put $@ back in case we altered it along the way.
- return $$value ;
- }
- if(ref($value) ne 'CODE'){
- $@ = $at; # Put $@ back in case we altered it along the way.
- return $value ;
- }
+ return $$value if ref($value) eq 'SCALAR';
+ return $value unless ref($value) eq 'CODE';
{
local $SIG{'__DIE__'};
@@ -282,19 +239,18 @@ sub maketext {
# If we make it here, there was an exception thrown in the
# call to $value, and so scream:
if ($@) {
+ my $err = $@;
# pretty up the error message
- $@ =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
+ $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?}
{\n in bracket code [compiled line $1],}s;
#$err =~ s/\n?$/\n/s;
- Carp::croak "Error in maketexting \"$phrase\":\n$@ as used";
+ Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
# Rather unexpected, but suppose that the sub tried calling
# a method that didn't exist.
}
else {
- $@ = $at; # Put $@ back in case we altered it along the way.
return $value;
}
- $@ = $at; # Put $@ back in case we altered it along the way.
}
###########################################################################
@@ -344,7 +300,7 @@ sub _langtag_munging {
my($base_class, @languages) = @_;
# We have all these DEBUG statements because otherwise it's hard as hell
- # to diagnose if/when something goes wrong.
+ # to diagnose ifwhen something goes wrong.
DEBUG and warn 'Lgs1: ', map("<$_>", @languages), "\n";
@@ -391,6 +347,7 @@ sub _langtag_munging {
###########################################################################
sub _ambient_langprefs {
+ require I18N::LangTags::Detect;
return I18N::LangTags::Detect::detect();
}
@@ -430,6 +387,10 @@ sub _add_supers {
#
###########################################################################
+use Locale::Maketext::GutsLoader;
+
+###########################################################################
+
my %tried = ();
# memoization of whether we've used this module, or found it unusable.
@@ -439,18 +400,16 @@ sub _try_use { # Basically a wrapper around "require Modulename"
my $module = $_[0]; # ASSUME sane module name!
{ no strict 'refs';
- no warnings 'once';
return($tried{$module} = 1)
if %{$module . '::Lexicon'} or @{$module . '::ISA'};
# weird case: we never use'd it, but there it is!
}
DEBUG and warn " About to use $module ...\n";
-
- local $SIG{'__DIE__'};
- local $@;
- eval "require $module"; # used to be "use $module", but no point in that.
-
+ {
+ local $SIG{'__DIE__'};
+ eval "require $module"; # used to be "use $module", but no point in that.
+ }
if($@) {
DEBUG and warn "Error using $module \: $@\n";
return $tried{$module} = 0;
@@ -494,312 +453,4 @@ sub _lex_refs { # report the lexicon references for this handle's class
sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
-#--------------------------------------------------------------------------
-
-sub _compile {
- # This big scary routine compiles an entry.
- # It returns either a coderef if there's brackety bits in this, or
- # otherwise a ref to a scalar.
-
- my $string_to_compile = $_[1]; # There are taint issues using regex on @_ - perlbug 60378,27344
-
- # The while() regex is more expensive than this check on strings that don't need a compile.
- # this op causes a ~2% speed hit for strings that need compile and a 250% speed improvement
- # on strings that don't need compiling.
- return \"$string_to_compile" if($string_to_compile !~ m/[\[~\]]/ms); # return a string ref if chars [~] are not in the string
-
- my $target = ref($_[0]) || $_[0];
-
- my(@code);
- my(@c) = (''); # "chunks" -- scratch.
- my $call_count = 0;
- my $big_pile = '';
- {
- my $in_group = 0; # start out outside a group
- my($m, @params); # scratch
-
- while($string_to_compile =~ # Iterate over chunks.
- m/(
- [^\~\[\]]+ # non-~[] stuff (Capture everything else here)
- |
- ~. # ~[, ~], ~~, ~other
- |
- \[ # [ presumably opening a group
- |
- \] # ] presumably closing a group
- |
- ~ # terminal ~ ?
- |
- $
- )/xgs
- ) {
- DEBUG>2 and warn qq{ "$1"\n};
-
- if($1 eq '[' or $1 eq '') { # "[" or end
- # Whether this is "[" or end, force processing of any
- # preceding literal.
- if($in_group) {
- if($1 eq '') {
- $target->_die_pointing($string_to_compile, 'Unterminated bracket group');
- }
- else {
- $target->_die_pointing($string_to_compile, 'You can\'t nest bracket groups');
- }
- }
- else {
- if ($1 eq '') {
- DEBUG>2 and warn " [end-string]\n";
- }
- else {
- $in_group = 1;
- }
- die "How come \@c is empty?? in <$string_to_compile>" unless @c; # sanity
- if(length $c[-1]) {
- # Now actually processing the preceding literal
- $big_pile .= $c[-1];
- if($USE_LITERALS and (
- (ord('A') == 65)
- ? $c[-1] !~ m/[^\x20-\x7E]/s
- # ASCII very safe chars
- : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
- # EBCDIC very safe chars
- )) {
- # normal case -- all very safe chars
- $c[-1] =~ s/'/\\'/g;
- push @code, q{ '} . $c[-1] . "',\n";
- $c[-1] = ''; # reuse this slot
- }
- else {
- $c[-1] =~ s/\\\\/\\/g;
- push @code, ' $c[' . $#c . "],\n";
- push @c, ''; # new chunk
- }
- }
- # else just ignore the empty string.
- }
-
- }
- elsif($1 eq ']') { # "]"
- # close group -- go back in-band
- if($in_group) {
- $in_group = 0;
-
- DEBUG>2 and warn " --Closing group [$c[-1]]\n";
-
- # And now process the group...
-
- if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
- DEBUG>2 and warn " -- (Ignoring)\n";
- $c[-1] = ''; # reset out chink
- next;
- }
-
- #$c[-1] =~ s/^\s+//s;
- #$c[-1] =~ s/\s+$//s;
- ($m,@params) = split(/,/, $c[-1], -1); # was /\s*,\s*/
-
- # A bit of a hack -- we've turned "~,"'s into DELs, so turn
- # 'em into real commas here.
- if (ord('A') == 65) { # ASCII, etc
- foreach($m, @params) { tr/\x7F/,/ }
- }
- else { # EBCDIC (1047, 0037, POSIX-BC)
- # Thanks to Peter Prymmer for the EBCDIC handling
- foreach($m, @params) { tr/\x07/,/ }
- }
-
- # Special-case handling of some method names:
- if($m eq '_*' or $m =~ m/^_(-?\d+)$/s) {
- # Treat [_1,...] as [,_1,...], etc.
- unshift @params, $m;
- $m = '';
- }
- elsif($m eq '*') {
- $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
- }
- elsif($m eq '#') {
- $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
- }
-
- # Most common case: a simple, legal-looking method name
- if($m eq '') {
- # 0-length method name means to just interpolate:
- push @code, ' (';
- }
- elsif($m =~ /^\w+$/s
- # exclude anything fancy, especially fully-qualified module names
- ) {
- push @code, ' $_[0]->' . $m . '(';
- }
- else {
- # TODO: implement something? or just too icky to consider?
- $target->_die_pointing(
- $string_to_compile,
- "Can't use \"$m\" as a method name in bracket group",
- 2 + length($c[-1])
- );
- }
-
- pop @c; # we don't need that chunk anymore
- ++$call_count;
-
- foreach my $p (@params) {
- if($p eq '_*') {
- # Meaning: all parameters except $_[0]
- $code[-1] .= ' @_[1 .. $#_], ';
- # and yes, that does the right thing for all @_ < 3
- }
- elsif($p =~ m/^_(-?\d+)$/s) {
- # _3 meaning $_[3]
- $code[-1] .= '$_[' . (0 + $1) . '], ';
- }
- elsif($USE_LITERALS and (
- (ord('A') == 65)
- ? $p !~ m/[^\x20-\x7E]/s
- # ASCII very safe chars
- : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
- # EBCDIC very safe chars
- )) {
- # Normal case: a literal containing only safe characters
- $p =~ s/'/\\'/g;
- $code[-1] .= q{'} . $p . q{', };
- }
- else {
- # Stow it on the chunk-stack, and just refer to that.
- push @c, $p;
- push @code, ' $c[' . $#c . '], ';
- }
- }
- $code[-1] .= "),\n";
-
- push @c, '';
- }
- else {
- $target->_die_pointing($string_to_compile, q{Unbalanced ']'});
- }
-
- }
- elsif(substr($1,0,1) ne '~') {
- # it's stuff not containing "~" or "[" or "]"
- # i.e., a literal blob
- my $text = $1;
- $text =~ s/\\/\\\\/g;
- $c[-1] .= $text;
-
- }
- elsif($1 eq '~~') { # "~~"
- $c[-1] .= '~';
-
- }
- elsif($1 eq '~[') { # "~["
- $c[-1] .= '[';
-
- }
- elsif($1 eq '~]') { # "~]"
- $c[-1] .= ']';
-
- }
- elsif($1 eq '~,') { # "~,"
- if($in_group) {
- # This is a hack, based on the assumption that no-one will actually
- # want a DEL inside a bracket group. Let's hope that's it's true.
- if (ord('A') == 65) { # ASCII etc
- $c[-1] .= "\x7F";
- }
- else { # EBCDIC (cp 1047, 0037, POSIX-BC)
- $c[-1] .= "\x07";
- }
- }
- else {
- $c[-1] .= '~,';
- }
-
- }
- elsif($1 eq '~') { # possible only at string-end, it seems.
- $c[-1] .= '~';
-
- }
- else {
- # It's a "~X" where X is not a special character.
- # Consider it a literal ~ and X.
- my $text = $1;
- $text =~ s/\\/\\\\/g;
- $c[-1] .= $text;
- }
- }
- }
-
- if($call_count) {
- undef $big_pile; # Well, nevermind that.
- }
- else {
- # It's all literals! Ahwell, that can happen.
- # So don't bother with the eval. Return a SCALAR reference.
- return \$big_pile;
- }
-
- die q{Last chunk isn't null??} if @c and length $c[-1]; # sanity
- DEBUG and warn scalar(@c), " chunks under closure\n";
- if(@code == 0) { # not possible?
- DEBUG and warn "Empty code\n";
- return \'';
- }
- elsif(@code > 1) { # most cases, presumably!
- unshift @code, "join '',\n";
- }
- unshift @code, "use strict; sub {\n";
- push @code, "}\n";
-
- DEBUG and warn @code;
- my $sub = eval(join '', @code);
- die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
- return $sub;
-}
-
-#--------------------------------------------------------------------------
-
-sub _die_pointing {
- # This is used by _compile to throw a fatal error
- my $target = shift; # class name
- # ...leaving $_[0] the error-causing text, and $_[1] the error message
-
- my $i = index($_[0], "\n");
-
- my $pointy;
- my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
- if($pos < 1) {
- $pointy = "^=== near there\n";
- }
- else { # we need to space over
- my $first_tab = index($_[0], "\t");
- if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
- # No tabs, or the first tab is harmlessly after where we will point to,
- # AND we're far enough from the margin that we can draw a proper arrow.
- $pointy = ('=' x $pos) . "^ near there\n";
- }
- else {
- # tabs screw everything up!
- $pointy = substr($_[0],0,$pos);
- $pointy =~ tr/\t //cd;
- # make everything into whitespace, but preserving tabs
- $pointy .= "^=== near there\n";
- }
- }
-
- my $errmsg = "$_[1], in\:\n$_[0]";
-
- if($i == -1) {
- # No newline.
- $errmsg .= "\n" . $pointy;
- }
- elsif($i == (length($_[0]) - 1) ) {
- # Already has a newline at end.
- $errmsg .= $pointy;
- }
- else {
- # don't bother with the pointy bit, I guess.
- }
- Carp::croak( "$errmsg via $target, as used" );
-}
-
1;
diff --git a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm
index 35a71ab5094..daa9840260a 100644
--- a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm
+++ b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm
@@ -1,26 +1,49 @@
package Locale::Maketext::GutsLoader;
-use Locale::Maketext;
-
-our $VERSION = '1.20';
+$VERSION = '1.13';
+use strict;
sub zorp { return scalar @_ }
-=head1 NAME
-
-Locale::Maketext::GutsLoader - Deprecated module to load Locale::Maketext utf8 code
-
-=head1 SYNOPSIS
-
- # Do this instead please
- use Locale::Maketext
-
-=head1 DESCRIPTION
-
-Previously Locale::Maketext::Guts performed some magic to load
-Locale::Maketext when utf8 was unavailable. The subs this module provided
-were merged back into Locale::Maketext.
-
-=cut
+BEGIN {
+ $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__;
+ *Locale::Maketext::DEBUG = sub () {0}
+ unless defined &Locale::Maketext::DEBUG;
+}
+
+#
+# This whole drama is so that we can load the utf8'd code
+# in Locale::Maketext::Guts, but if that fails, snip the
+# utf8 and then try THAT.
+#
+
+$Locale::Maketext::GUTSPATH = '';
+Locale::Maketext::DEBUG and warn "Requiring Locale::Maketext::Guts...\n";
+eval 'require Locale::Maketext::Guts';
+
+if ($@) {
+ my $path = $Locale::Maketext::GUTSPATH;
+
+ die "Can't load Locale::Maketext::Guts\nAborting" unless $path;
+
+ die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting"
+ unless -e $path and -f _ and -r _;
+
+ open(IN, $path) or die "Can't read-open $path\nAborting";
+
+ my $source;
+ { local $/; $source = <IN>; }
+ close(IN);
+ unless( $source =~ s/\b(use utf8)/# $1/ ) {
+ Locale::Maketext::DEBUG and
+ print "I didn't see 'use utf8' in $path\n";
+ }
+ eval $source;
+ die "Can't compile $path\n...The error I got was:\n$@\nAborting" if $@;
+ Locale::Maketext::DEBUG and warn "Non-utf8'd Locale::Maketext::Guts fine\n";
+}
+else {
+ Locale::Maketext::DEBUG and warn "Loaded Locale::Maketext::Guts fine\n";
+}
1;
diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/corelist b/gnu/usr.bin/perl/dist/Module-CoreList/corelist
index aa4a94571a3..08f198f4ac8 100644
--- a/gnu/usr.bin/perl/dist/Module-CoreList/corelist
+++ b/gnu/usr.bin/perl/dist/Module-CoreList/corelist
@@ -10,13 +10,9 @@ See L<Module::CoreList> for one.
=head1 SYNOPSIS
- corelist -v
- corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
- corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
- corelist [-r <PerlVersion>] ...
- corelist --feature <FeatureName> [<FeatureName>] ...
- corelist --diff PerlVersion PerlVersion
- corelist --upstream <ModuleName>
+ corelist -v
+ corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
+ corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
=head1 OPTIONS
@@ -27,67 +23,32 @@ See L<Module::CoreList> for one.
lists all versions of the given module (or the matching modules, in case you
used a module regexp) in the perls Module::CoreList knows about.
- corelist -a Unicode
-
- Unicode was first released with perl v5.6.2
- v5.6.2 3.0.1
- v5.8.0 3.2.0
- v5.8.1 4.0.0
- v5.8.2 4.0.0
- v5.8.3 4.0.0
- v5.8.4 4.0.1
- v5.8.5 4.0.1
- v5.8.6 4.0.1
- v5.8.7 4.1.0
- v5.8.8 4.1.0
- v5.8.9 5.1.0
- v5.9.0 4.0.0
- v5.9.1 4.0.0
- v5.9.2 4.0.1
- v5.9.3 4.1.0
- v5.9.4 4.1.0
- v5.9.5 5.0.0
- v5.10.0 5.0.0
- v5.10.1 5.1.0
- v5.11.0 5.1.0
- v5.11.1 5.1.0
- v5.11.2 5.1.0
- v5.11.3 5.2.0
- v5.11.4 5.2.0
- v5.11.5 5.2.0
- v5.12.0 5.2.0
- v5.12.1 5.2.0
- v5.12.2 5.2.0
- v5.12.3 5.2.0
- v5.12.4 5.2.0
- v5.13.0 5.2.0
- v5.13.1 5.2.0
- v5.13.2 5.2.0
- v5.13.3 5.2.0
- v5.13.4 5.2.0
- v5.13.5 5.2.0
- v5.13.6 5.2.0
- v5.13.7 6.0.0
- v5.13.8 6.0.0
- v5.13.9 6.0.0
- v5.13.10 6.0.0
- v5.13.11 6.0.0
- v5.14.0 6.0.0
- v5.14.1 6.0.0
- v5.15.0 6.0.0
+ corelist -a utf8
+
+ utf8 was first released with perl 5.006
+ 5.006 undef
+ 5.006001 undef
+ 5.006002 undef
+ 5.007003 1.00
+ 5.008 1.00
+ 5.008001 1.02
+ 5.008002 1.02
+ 5.008003 1.02
+ 5.008004 1.03
+ 5.008005 1.04
+ 5.008006 1.04
+ 5.008007 1.05
+ 5.008008 1.06
+ 5.009 1.02
+ 5.009001 1.02
+ 5.009002 1.04
+ 5.009003 1.06
=item -d
finds the first perl version where a module has been released by
date, and not by version number (as is the default).
-=item --diff
-
-Given two versions of perl, this prints a human-readable table of all module
-changes between the two. The output format may change in the future, and is
-meant for I<humans>, not programs. For programs, use the L<Module::CoreList>
-API.
-
=item -? or -help
help! help! help! to see more help, try --man.
@@ -107,21 +68,6 @@ like C<5.8.8>.)
In module filtering context, it can be used as Perl version filter.
-=item -r
-
-lists all of the perl releases and when they were released
-
-If you pass a perl version you get the release date for that version only.
-
-=item --feature, -f
-
-lists the first version bundle of each named feature given
-
-=item --upstream, -u
-
-Shows if the given module is primarily maintained in perl core or on CPAN
-and bug tracker URL.
-
=back
As a special case, if you specify the module name C<Unicode>, you'll get
@@ -131,50 +77,22 @@ requested perl versions.
=cut
use Module::CoreList;
-use Getopt::Long qw(:config no_ignore_case);
+use Getopt::Long;
use Pod::Usage;
use strict;
use warnings;
-use List::Util qw/maxstr/;
my %Opts;
-GetOptions(
- \%Opts,
- qw[ help|?! man! r|release:s v|version:s a! d diff|D feature|f u|upstream ]
-);
+GetOptions(\%Opts, qw[ help|?! man! v|version:s a! d ] );
pod2usage(1) if $Opts{help};
pod2usage(-verbose=>2) if $Opts{man};
-if(exists $Opts{r} ){
- if ( !$Opts{r} ) {
- print "\nModule::CoreList has release info for the following perl versions:\n";
- my $versions = { };
- my $max_ver_len = max_mod_len(\%Module::CoreList::released);
- for my $ver ( grep !/0[01]0$/, sort keys %Module::CoreList::released ) {
- printf "%-${max_ver_len}s %s\n", format_perl_version($ver), $Module::CoreList::released{$ver};
- }
- print "\n";
- exit 0;
- }
-
- my $num_r = numify_version( $Opts{r} );
- my $version_hash = Module::CoreList->find_version($num_r);
-
- if( !$version_hash ) {
- print "\nModule::CoreList has no info on perl $Opts{r}\n\n";
- exit 1;
- }
-
- printf "Perl %s was released on %s\n\n", format_perl_version($num_r), $Module::CoreList::released{$num_r};
- exit 0;
-}
-
if(exists $Opts{v} ){
if( !$Opts{v} ) {
print "\nModule::CoreList has info on the following perl versions:\n";
- print format_perl_version($_)."\n" for grep !/0[01]0$/, sort keys %Module::CoreList::version;
+ print format_perl_version($_)."\n" for sort keys %Module::CoreList::version;
print "\n";
exit 0;
}
@@ -198,78 +116,6 @@ if(exists $Opts{v} ){
}
}
-if ($Opts{diff}) {
- if(@ARGV != 2) {
- die "\nprovide exactly two perl core versions to diff with --diff\n";
- }
-
- my ($old_ver, $new_ver) = @ARGV;
-
- my $old = numify_version($old_ver);
- my $new = numify_version($new_ver);
-
- my %diff = Module::CoreList::changes_between($old, $new);
-
- for my $lib (sort keys %diff) {
- my $diff = $diff{$lib};
-
- my $was = ! exists $diff->{left} ? '(absent)'
- : ! defined $diff->{left} ? '(undef)'
- : $diff->{left};
-
- my $now = ! exists $diff->{right} ? '(absent)'
- : ! defined $diff->{right} ? '(undef)'
- : $diff->{right};
-
- printf "%-35s %10s %10s\n", $lib, $was, $now;
- }
- exit(0);
-}
-
-if ($Opts{feature}) {
- die "\n--feature is only available with perl v5.16.0 or greater\n"
- if $] < 5.016;
-
- die "\nprovide at least one feature name to --feature\n"
- unless @ARGV;
-
- no warnings 'once';
- require feature;
-
- my %feature2version;
- my @bundles = map { $_->[0] }
- sort { $b->[1] <=> $a->[1] }
- map { [$_, numify_version($_)] }
- grep { not /[^0-9.]/ }
- keys %feature::feature_bundle;
-
- for my $version (@bundles) {
- $feature2version{$_} = $version =~ /^\d\.\d+$/ ? "$version.0" : $version
- for @{ $feature::feature_bundle{$version} };
- }
-
- # allow internal feature names, just in case someone gives us __SUB__
- # instead of current_sub.
- while (my ($name, $internal) = each %feature::feature) {
- $internal =~ s/^feature_//;
- $feature2version{$internal} = $feature2version{$name}
- if $feature2version{$name};
- }
-
- my $when = maxstr(values %Module::CoreList::released);
- print "\n","Data for $when\n";
-
- for my $feature (@ARGV) {
- print "feature \"$feature\" ",
- exists $feature2version{$feature}
- ? "was first released with the perl "
- . format_perl_version(numify_version($feature2version{$feature}))
- . " feature bundle\n"
- : "doesn't exist (or so I think)\n";
- }
- exit(0);
-}
-
if ( !@ARGV ) {
pod2usage(0);
}
@@ -331,32 +177,16 @@ sub module_version {
? Module::CoreList->removed_from_by_date($mod)
: Module::CoreList->removed_from($mod);
- my $when = maxstr(values %Module::CoreList::released);
- print "\n","Data for $when\n";
-
if( defined $ret ) {
- my $deprecated = Module::CoreList->deprecated_in($mod);
$msg .= " was ";
$msg .= "first " unless $ver;
$msg .= "released with perl " . format_perl_version($ret);
- $msg .= ( $rem ? ',' : ' and' ) . " deprecated (will be CPAN-only) in " . format_perl_version($deprecated) if $deprecated;
$msg .= " and removed from " . format_perl_version($rem) if $rem;
} else {
$msg .= " was not in CORE (or so I think)";
}
- print $msg,"\n";
-
- if( defined $ret and exists $Opts{u} ) {
- my $upsream = $Module::CoreList::upstream{$mod};
- $upsream = 'undef' unless $upsream;
- print "upstream: $upsream\n";
- if ( $upsream ne 'blead' ) {
- my $bugtracker = $Module::CoreList::bug_tracker{$mod};
- $bugtracker = 'unknown' unless $bugtracker;
- print "bug tracker: $bugtracker\n";
- }
- }
+ print "\n",$msg,"\n";
if(defined $ret and exists $Opts{a} and $Opts{a}){
display_a($mod);
@@ -383,7 +213,7 @@ sub max {
sub display_a {
my $mod = shift;
- for my $v (grep !/0[01]0$/, sort keys %Module::CoreList::version ) {
+ for my $v (grep !/000$/, sort keys %Module::CoreList::version ) {
next unless exists $Module::CoreList::version{$v}{$mod};
my $mod_v = $Module::CoreList::version{$v}{$mod} || 'undef';
diff --git a/gnu/usr.bin/perl/dist/Storable/Storable.pm b/gnu/usr.bin/perl/dist/Storable/Storable.pm
index 7d8a01198d5..7627943b55d 100644
--- a/gnu/usr.bin/perl/dist/Storable/Storable.pm
+++ b/gnu/usr.bin/perl/dist/Storable/Storable.pm
@@ -1,14 +1,13 @@
#
-# Copyright (c) 1995-2001, Raphael Manfredi
-# Copyright (c) 2002-2013 by the Perl 5 Porters
+# Copyright (c) 1995-2000, Raphael Manfredi
#
# You may redistribute only under the same terms as Perl 5, as specified
# in the README file that comes with the distribution.
#
-require XSLoader;
+require DynaLoader;
require Exporter;
-package Storable; @ISA = qw(Exporter);
+package Storable; @ISA = qw(Exporter DynaLoader);
@EXPORT = qw(store retrieve);
@EXPORT_OK = qw(
@@ -20,32 +19,24 @@ package Storable; @ISA = qw(Exporter);
file_magic read_magic
);
+use AutoLoader;
+use FileHandle;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.49_01';
+$VERSION = '2.22';
+*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
-BEGIN {
- if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {
- Log::Agent->import;
- }
- #
- # Use of Log::Agent is optional. If it hasn't imported these subs then
- # provide a fallback implementation.
- #
- unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) {
- require Carp;
- *logcroak = sub {
- Carp::croak(@_);
- };
- }
- unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) {
- require Carp;
- *logcarp = sub {
- Carp::carp(@_);
- };
- }
+#
+# Use of Log::Agent is optional
+#
+
+{
+ local $SIG{__DIE__};
+ eval "use Log::Agent";
}
+require Carp;
+
#
# They might miss :flock in Fcntl
#
@@ -66,12 +57,28 @@ sub CLONE {
Storable::init_perinterp();
}
+# Can't Autoload cleanly as this clashes 8.3 with &retrieve
+sub retrieve_fd { &fd_retrieve } # Backward compatibility
+
# By default restricted hashes are downgraded on earlier perls.
$Storable::downgrade_restricted = 1;
$Storable::accept_future_minor = 1;
+bootstrap Storable;
+1;
+__END__
+#
+# Use of Log::Agent is optional. If it hasn't imported these subs then
+# Autoloader will kindly supply our fallback implementation.
+#
+
+sub logcroak {
+ Carp::croak(@_);
+}
-XSLoader::load('Storable', $Storable::VERSION);
+sub logcarp {
+ Carp::carp(@_);
+}
#
# Determine whether locking is possible, but only when needed.
@@ -109,10 +116,8 @@ EOM
}
sub file_magic {
- require IO::File;
-
my $file = shift;
- my $fh = IO::File->new;
+ my $fh = new FileHandle;
open($fh, "<". $file) || die "Can't open '$file': $!";
binmode($fh);
defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!";
@@ -146,14 +151,14 @@ sub read_magic {
$net_order = 0;
}
else {
- $buf =~ s/(.)//s;
- my $major = (ord $1) >> 1;
+ $net_order = ord(substr($buf, 0, 1, ""));
+ my $major = $net_order >> 1;
return undef if $major > 4; # sanity (assuming we never go that high)
$info{major} = $major;
- $net_order = (ord $1) & 0x01;
+ $net_order &= 0x01;
if ($major > 1) {
- return undef unless $buf =~ s/(.)//s;
- my $minor = ord $1;
+ return undef unless length($buf);
+ my $minor = ord(substr($buf, 0, 1, ""));
$info{minor} = $minor;
$info{version} = "$major.$minor";
$info{version_nv} = sprintf "%d.%03d", $major, $minor;
@@ -166,16 +171,17 @@ sub read_magic {
$info{netorder} = $net_order;
unless ($net_order) {
- return undef unless $buf =~ s/(.)//s;
- my $len = ord $1;
+ return undef unless length($buf);
+ my $len = ord(substr($buf, 0, 1, ""));
return undef unless length($buf) >= $len;
return undef unless $len == 4 || $len == 8; # sanity
- @info{qw(byteorder intsize longsize ptrsize)}
- = unpack "a${len}CCC", $buf;
- (substr $buf, 0, $len + 3) = '';
+ $info{byteorder} = substr($buf, 0, $len, "");
+ $info{intsize} = ord(substr($buf, 0, 1, ""));
+ $info{longsize} = ord(substr($buf, 0, 1, ""));
+ $info{ptrsize} = ord(substr($buf, 0, 1, ""));
if ($info{version_nv} >= 2.002) {
- return undef unless $buf =~ s/(.)//s;
- $info{nvsize} = ord $1;
+ return undef unless length($buf);
+ $info{nvsize} = ord(substr($buf, 0, 1, ""));
}
}
$info{hdrsize} = $buflen - length($buf);
@@ -256,18 +262,11 @@ sub _store {
my $ret;
# Call C routine nstore or pstore, depending on network order
eval { $ret = &$xsptr(*FILE, $self) };
- # close will return true on success, so the or short-circuits, the ()
- # expression is true, and for that case the block will only be entered
- # if $@ is true (ie eval failed)
- # if close fails, it returns false, $ret is altered, *that* is (also)
- # false, so the () expression is false, !() is true, and the block is
- # entered.
- if (!(close(FILE) or undef $ret) || $@) {
- unlink($file) or warn "Can't unlink $file: $!\n";
- }
+ close(FILE) or $ret = undef;
+ unlink($file) or warn "Can't unlink $file: $!\n" if $@ || !defined $ret;
logcroak $@ if $@ =~ s/\.?\n$/,/;
$@ = $da;
- return $ret;
+ return $ret ? $ret : undef;
}
#
@@ -306,13 +305,13 @@ sub _store_fd {
logcroak $@ if $@ =~ s/\.?\n$/,/;
local $\; print $file ''; # Autoflush the file if wanted
$@ = $da;
- return $ret;
+ return $ret ? $ret : undef;
}
#
# freeze
#
-# Store object and its hierarchy in memory and return a scalar
+# Store oject and its hierarchy in memory and return a scalar
# containing the result.
#
sub freeze {
@@ -402,8 +401,6 @@ sub fd_retrieve {
return $self;
}
-sub retrieve_fd { &fd_retrieve } # Backward compatibility
-
#
# thaw
#
@@ -906,12 +903,12 @@ This returns the file format version as number. It is a string like
"2.007". This value is suitable for numeric comparisons.
The constant function C<Storable::BIN_VERSION_NV> returns a comparable
-number that represents the highest file version number that this
-version of Storable fully supports (but see discussion of
+number that represent the highest file version number that this
+version of Storable fully support (but see discussion of
C<$Storable::accept_future_minor> above). The constant
C<Storable::BIN_WRITE_VERSION_NV> function returns what file version
is written and might be less than C<Storable::BIN_VERSION_NV> in some
-configurations.
+configuations.
=item C<major>, C<minor>
@@ -1020,38 +1017,6 @@ compartment:
=for example_testing
is( $code->(), 42 );
-=head1 SECURITY WARNING
-
-B<Do not accept Storable documents from untrusted sources!>
-
-Some features of Storable can lead to security vulnerabilities if you
-accept Storable documents from untrusted sources. Most obviously, the
-optional (off by default) CODE reference serialization feature allows
-transfer of code to the deserializing process. Furthermore, any
-serialized object will cause Storable to helpfully load the module
-corresponding to the class of the object in the deserializing module.
-For manipulated module names, this can load almost arbitrary code.
-Finally, the deserialized object's destructors will be invoked when
-the objects get destroyed in the deserializing process. Maliciously
-crafted Storable documents may put such objects in the value of
-a hash key that is overridden by another key/value pair in the
-same hash, thus causing immediate destructor execution.
-
-In a future version of Storable, we intend to provide options to disable
-loading modules for classes and to disable deserializing objects
-altogether. I<Nonetheless, Storable deserializing documents from
-untrusted sources is expected to have other, yet undiscovered,
-security concerns such as allowing an attacker to cause the deserializer
-to crash hard.>
-
-B<Therefore, let me repeat: Do not accept Storable documents from
-untrusted sources!>
-
-If your application requires accepting data from untrusted sources, you
-are best off with a less powerful and more-likely safe serialization format
-and implementation. If your data is sufficiently simple, JSON is a good
-choice and offers maximum interoperability.
-
=head1 WARNING
If you're using references as keys within your hash tables, you're bound
@@ -1086,8 +1051,8 @@ deal with them.
The store functions will C<croak> if they run into such references
unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that
-case, the fatal message is converted to a warning and some meaningless
-string is stored instead.
+case, the fatal message is turned in a warning and some
+meaningless string is stored instead.
Setting C<$Storable::canonical> may not yield frozen strings that
compare equal due to possible stringification of numbers. When the
@@ -1163,7 +1128,7 @@ correct behaviour.
What this means is that if you have data written by Storable 1.x running
on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux
then by default this Storable will refuse to read it, giving the error
-I<Byte order is not compatible>. If you have such data then you
+I<Byte order is not compatible>. If you have such data then you you
should set C<$Storable::interwork_56_64bit> to a true value to make this
Storable read and write files with the old header. You should also
migrate your data, or any older perl you are communicating with, to this
@@ -1182,7 +1147,7 @@ Thank you to (in chronological order):
Jarkko Hietaniemi <jhi@iki.fi>
Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
- Benjamin A. Holzman <bholzman@earthlink.net>
+ Benjamin A. Holzman <bah@ecnvantage.com>
Andrew Ford <A.Ford@ford-mason.co.uk>
Gisle Aas <gisle@aas.no>
Jeff Gresham <gresham_jeffrey@jpmorgan.com>
@@ -1193,8 +1158,6 @@ Thank you to (in chronological order):
Salvador Ortiz Garcia <sog@msg.com.mx>
Dominic Dunlop <domo@computer.org>
Erik Haugan <erik@solbors.no>
- Benjamin A. Holzman <ben.holzman@grantstreet.com>
- Reini Urban <rurban@cpanel.net>
for their bug reports, suggestions and contributions.
@@ -1206,9 +1169,7 @@ simply counting the objects instead of tagging them (leading to
a binary incompatibility for the Storable image starting at version
0.6--older images are, of course, still properly understood).
Murray Nesbitt made Storable thread-safe. Marc Lehmann added overloading
-and references to tied items support. Benjamin Holzman added a performance
-improvement for overloaded classes; thanks to Grant Street Group for footing
-the bill.
+and references to tied items support.
=head1 AUTHOR
diff --git a/gnu/usr.bin/perl/dist/base/lib/base.pm b/gnu/usr.bin/perl/dist/base/lib/base.pm
index 5d1378786de..2f6a19e4b9a 100644
--- a/gnu/usr.bin/perl/dist/base/lib/base.pm
+++ b/gnu/usr.bin/perl/dist/base/lib/base.pm
@@ -2,7 +2,7 @@ package base;
use strict 'vars';
use vars qw($VERSION);
-$VERSION = '2.22';
+$VERSION = '2.15';
$VERSION = eval $VERSION;
# constant.pm is slow
@@ -22,6 +22,12 @@ sub has_fields {
return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
}
+sub has_version {
+ my($base) = shift;
+ my $vglob = ${$base.'::'}{VERSION};
+ return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
+}
+
sub has_attr {
my($proto) = shift;
my($class) = ref $proto || $proto;
@@ -55,23 +61,6 @@ else {
}
}
-if ($] < 5.008) {
- *_module_to_filename = sub {
- (my $fn = $_[0]) =~ s!::!/!g;
- $fn .= '.pm';
- return $fn;
- }
-}
-else {
- *_module_to_filename = sub {
- (my $fn = $_[0]) =~ s!::!/!g;
- $fn .= '.pm';
- utf8::encode($fn);
- return $fn;
- }
-}
-
-
sub import {
my $class = shift;
@@ -81,6 +70,7 @@ sub import {
my $fields_base;
my $inheritor = caller(0);
+ my @isa_classes;
my @bases;
foreach my $base (@_) {
@@ -90,23 +80,18 @@ sub import {
next if grep $_->isa($base), ($inheritor, @bases);
- # Following blocks help isolate $SIG{__DIE__} changes
- {
+ if (has_version($base)) {
+ ${$base.'::VERSION'} = '-1, set by base.pm'
+ unless defined ${$base.'::VERSION'};
+ }
+ else {
my $sigdie;
{
local $SIG{__DIE__};
- my $fn = _module_to_filename($base);
- eval { require $fn };
+ eval "require $base";
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
- #
- # changing the check here is fragile - if the check
- # here isn't catching every error you want, you should
- # probably be using parent.pm, which doesn't try to
- # guess whether require is needed or failed,
- # see [perl #118561]
- die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s
- || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
unless (%{"$base\::"}) {
require Carp;
local $" = " ";
@@ -120,6 +105,8 @@ ERROR
}
# Make sure a global $SIG{__DIE__} makes it out of the localization.
$SIG{__DIE__} = $sigdie if defined $sigdie;
+ ${$base.'::VERSION'} = "-1, set by base.pm"
+ unless defined ${$base.'::VERSION'};
}
push @bases, $base;
@@ -134,6 +121,8 @@ ERROR
}
}
# Save this until the end so it's all or nothing if the above loop croaks.
+ push @{"$inheritor\::ISA"}, @isa_classes;
+
push @{"$inheritor\::ISA"}, @bases;
if( defined $fields_base ) {
@@ -217,26 +206,26 @@ those modules at the same time. Roughly similar in effect to
push @ISA, qw(Foo Bar);
}
-When C<base> tries to C<require> a module, it will not die if it cannot find
-the module's file, but will die on any other error. After all this, should
-your base class be empty, containing no symbols, C<base> will die. This is
-useful for inheriting from classes in the same file as yourself but where
-the filename does not match the base module name, like so:
+C<base> employs some heuristics to determine if a module has already been
+loaded, if it has it doesn't try again. If C<base> tries to C<require> the
+module it will not die if it cannot find the module's file, but will die on any
+other error. After all this, should your base class be empty, containing no
+symbols, it will die. This is useful for inheriting from classes in the same
+file as yourself, like so:
- # in Bar.pm
package Foo;
sub exclaim { "I can have such a thing?!" }
-
+
package Bar;
use base "Foo";
-There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim>
-subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>.
+If $VERSION is not detected even after loading it, <base> will define $VERSION
+in the base package, setting it to the string C<-1, set by base.pm>.
C<base> will also initialize the fields if one of the base classes has it.
Multiple inheritance of fields is B<NOT> supported, if two or more base classes
-each have inheritable fields the 'base' pragma will croak. See L<fields>
-for a description of this feature.
+each have inheritable fields the 'base' pragma will croak. See L<fields>,
+L<public> and L<protected> for a description of this feature.
The base class' C<import> method is B<not> called.
@@ -254,7 +243,7 @@ found in your path.
Attempting to inherit from yourself generates a warning.
- package Foo;
+ use Foo;
use base 'Foo';
=back
diff --git a/gnu/usr.bin/perl/dist/base/lib/fields.pm b/gnu/usr.bin/perl/dist/base/lib/fields.pm
index ad1a5cfa412..de6f379d9fe 100644
--- a/gnu/usr.bin/perl/dist/base/lib/fields.pm
+++ b/gnu/usr.bin/perl/dist/base/lib/fields.pm
@@ -11,7 +11,7 @@ unless( eval q{require warnings::register; warnings::register->import; 1} ) {
}
use vars qw(%attr $VERSION);
-$VERSION = '2.17';
+$VERSION = '2.15';
# constant.pm is slow
sub PUBLIC () { 2**0 }
@@ -200,13 +200,9 @@ fields - compile-time class fields
my $var = Foo->new;
$var->{foo} = 42;
- # this will generate a run-time error
+ # this will generate an error
$var->{zap} = 42;
- # this will generate a compile-time error
- my Foo $foo = Foo->new;
- $foo->{zap} = 24;
-
# subclassing
{
package Bar;
@@ -224,34 +220,38 @@ fields - compile-time class fields
=head1 DESCRIPTION
-The C<fields> pragma enables compile-time and run-time verified class
-fields.
+The C<fields> pragma enables compile-time verified class fields.
NOTE: The current implementation keeps the declared fields in the %FIELDS
hash of the calling package, but this may change in future versions.
Do B<not> update the %FIELDS hash directly, because it must be created
at compile-time for it to be fully useful, as is done by this pragma.
-If a typed lexical variable (C<my Class
-$var>) holding a reference is used to access a
+B<Only valid for perl before 5.9.0:>
+
+If a typed lexical variable holding a reference is used to access a
hash element and a package with the same name as the type has
-declared class fields using this pragma, then the hash key is
-verified at compile time. If the variables are not typed, access is
-only checked at run time.
+declared class fields using this pragma, then the operation is
+turned into an array access at compile time.
+
The related C<base> pragma will combine fields from base classes and any
fields declared using the C<fields> pragma. This enables field
-inheritance to work properly. Inherited fields can be overridden but
-will generate a warning if warnings are enabled.
+inheritance to work properly.
+
+Field names that start with an underscore character are made private to
+the class and are not visible to subclasses. Inherited fields can be
+overridden but will generate a warning if used together with the C<-w>
+switch.
+
+B<Only valid for perls before 5.9.0:>
-B<Only valid for Perl 5.8.x and earlier:> Field names that start with an
-underscore character are made private to the class and are not visible
-to subclasses.
+The effect of all this is that you can have objects with named
+fields which are as compact and as fast arrays to access. This only
+works as long as the objects are accessed through properly typed
+variables. If the objects are not typed, access is only checked at
+run time.
-Also, B<in Perl 5.8.x and earlier>, this pragma uses pseudo-hashes, the
-effect being that you can have objects with named fields which are as
-compact and as fast arrays to access, as long as the objects are
-accessed through properly typed variables.
The following functions are supported:
@@ -259,8 +259,15 @@ The following functions are supported:
=item new
-fields::new() creates and blesses a hash comprised of the fields declared
-using the C<fields> pragma into the specified class. It is the
+B< perl before 5.9.0: > fields::new() creates and blesses a
+pseudo-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+B< perl 5.9.0 and higher: > fields::new() creates and blesses a
+restricted-hash comprised of the fields declared using the C<fields>
+pragma into the specified class.
+
+This function is usable with or without pseudo-hashes. It is the
recommended way to construct a fields-based object.
This makes it possible to write a constructor like this:
@@ -271,18 +278,14 @@ This makes it possible to write a constructor like this:
sub new {
my $self = shift;
$self = fields::new($self) unless ref $self;
- $self->{cat} = 'meow'; # scalar element
- @$self{'dog','bird'} = ('bark','tweet'); # slice
+ $self->{cat} = 'meow'; # scalar element
+ @$self{'dog','bird'} = ('bark','tweet'); # slice
return $self;
}
=item phash
-B<This function only works in Perl 5.8.x and earlier.> Pseudo-hashes
-were removed from Perl as of 5.10. Consider using restricted hashes or
-fields::new() instead (which itself uses restricted hashes under 5.10+).
-See L<Hash::Util>. Using fields::phash() under 5.10 or higher will
-cause an error.
+B< before perl 5.9.0: >
fields::phash() can be used to create and initialize a plain (unblessed)
pseudo-hash. This function should always be used instead of creating
@@ -309,10 +312,16 @@ be used to construct the pseudo hash. Examples:
my $pseudohash = fields::phash(%args);
+B< perl 5.9.0 and higher: >
+
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes or fields::new() instead. Using fields::phash()
+will cause an error.
+
=back
=head1 SEE ALSO
-L<base>, L<Hash::Util>
+L<base>
=cut