- rebuild with new gdbm

- clean spec a little more
This commit is contained in:
Marcela Mašláňová 2010-03-11 08:56:39 +00:00
parent 75aad87998
commit 26547351fb
24 changed files with 15 additions and 71876 deletions

View File

@ -1,978 +0,0 @@
Archive-Extract-0.30
diff -urN perl-5.10.0.orig/lib/Archive/Extract/t/01_Archive-Extract.t perl-5.10.0/lib/Archive/Extract/t/01_Archive-Extract.t
--- perl-5.10.0.orig/lib/Archive/Extract/t/01_Archive-Extract.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Archive/Extract/t/01_Archive-Extract.t 2009-03-10 12:31:09.000000000 +0100
@@ -58,6 +58,7 @@
$Archive::Extract::VERBOSE = $Archive::Extract::VERBOSE = $Debug;
$Archive::Extract::WARN = $Archive::Extract::WARN = $Debug ? 1 : 0;
+
my $tmpl = {
### plain files
'x.bz2' => { programs => [qw[bunzip2]],
@@ -105,6 +106,11 @@
method => 'is_zip',
outfile => 'a',
},
+ 'x.lzma' => { programs => [qw[unlzma]],
+ modules => [qw[Compress::unLZMA]],
+ method => 'is_lzma',
+ outfile => 'a',
+ },
### with a directory
'y.tbz' => { programs => [qw[bunzip2 tar]],
modules => [qw[Archive::Tar
@@ -201,8 +207,53 @@
ok( $obj, " Object created based on '$type'" );
ok( !$obj->error, " No error logged" );
}
+
+ ### test unknown type
+ { ### must turn on warnings to catch error here
+ local $Archive::Extract::WARN = 1;
+
+ my $warnings;
+ local $SIG{__WARN__} = sub { $warnings .= "@_" };
+
+ my $ae = $Class->new( archive => $Me );
+ ok( !$ae, " No archive created based on '$Me'" );
+ ok( !$Class->error, " Error not captured in class method" );
+ ok( $warnings, " Error captured as warning" );
+ like( $warnings, qr/Cannot determine file type for/,
+ " Error is: unknown file type" );
+ }
}
+### test multiple errors
+### XXX whitebox test
+{ ### grab a random file from the template, so we can make an object
+ my $ae = Archive::Extract->new(
+ archive => File::Spec->catfile($SrcDir,[keys %$tmpl]->[0])
+ );
+ ok( $ae, "Archive created" );
+ ok( not($ae->error), " No errors yet" );
+
+ ### log a few errors
+ { local $Archive::Extract::WARN = 0;
+ $ae->_error( $_ ) for 1..5;
+ }
+
+ my $err = $ae->error;
+ ok( $err, " Errors retrieved" );
+
+ my $expect = join $/, 1..5;
+ is( $err, $expect, " As expected" );
+
+ ### this resets the errors
+ ### override the 'check' routine to return false, so we bail out of
+ ### extract() early and just run the error reset code;
+ { no warnings qw[once redefine];
+ local *Archive::Extract::check = sub { return };
+ $ae->extract;
+ }
+ ok( not($ae->error), " Errors erased after ->extract() call" );
+}
+
### XXX whitebox test
### test __get_extract_dir
SKIP: { my $meth = '__get_extract_dir';
@@ -237,15 +288,18 @@
}
}
-for my $switch (0,1) {
+### configuration to run in: allow perl or allow binaries
+for my $switch ( [0,1], [1,0] ) {
+ my $cfg = "PP: $switch->[0] Bin: $switch->[1]";
- local $Archive::Extract::PREFER_BIN = $switch;
- diag("Running extract with PREFER_BIN = $Archive::Extract::PREFER_BIN")
- if $Debug;
+ local $Archive::Extract::_ALLOW_PURE_PERL = $switch->[0];
+ local $Archive::Extract::_ALLOW_BIN = $switch->[1];
+
+ diag("Running extract with configuration: $cfg") if $Debug;
for my $archive (keys %$tmpl) {
- diag("Extracting $archive") if $Debug;
+ diag("Extracting $archive in config $cfg") if $Debug;
### check first if we can do the proper
@@ -291,12 +345,14 @@
### where to extract to -- try both dir and file for gz files
### XXX test me!
#my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
- my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z
+ my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z || $ae->is_lzma
? ($abs_path)
: ($OutDir);
skip "No binaries or modules to extract ".$archive,
- (10 * scalar @outs) if $mod_fail && $pgm_fail;
+ (10 * scalar @outs) if
+ ($mod_fail && ($pgm_fail || !$Archive::Extract::_ALLOW_BIN)) ||
+ ($pgm_fail && ($mod_fail || !$Archive::Extract::_ALLOW_PURE_PERL));
### we dont warnings spewed about missing modules, that might
### be a problem...
@@ -307,7 +363,7 @@
### test buffers ###
my $turn_off = !$use_buffer && !$pgm_fail &&
- $Archive::Extract::PREFER_BIN;
+ $Archive::Extract::_ALLOW_BIN;
### whitebox test ###
### stupid warnings ###
@@ -325,20 +381,24 @@
my $rv = $ae->extract( to => $to );
- ok( $rv, "extract() for '$archive' reports success");
-
- diag("Extractor was: " . $ae->_extractor) if $Debug;
-
SKIP: {
my $re = qr/^No buffer captured/;
my $err = $ae->error || '';
### skip buffer tests if we dont have buffers or
### explicitly turned them off
- skip "No buffers available", 7,
+ skip "No buffers available", 8
if ( $turn_off || !IPC::Cmd->can_capture_buffer)
&& $err =~ $re;
+ ### skip tests if we dont have an extractor
+ skip "No extractor available", 8
+ if $err =~ /Extract failed; no extractors available/;
+
+ ok( $rv, "extract() for '$archive' reports success ($cfg)");
+
+ diag("Extractor was: " . $ae->_extractor) if $Debug;
+
### if we /should/ have buffers, there should be
### no errors complaining we dont have them...
unlike( $err, $re,
@@ -346,10 +406,16 @@
### might be 1 or 2, depending wether we extracted
### a dir too
+ my $files = $ae->files || [];
my $file_cnt = grep { defined } $file, $dir;
- is( scalar @{ $ae->files || []}, $file_cnt,
+ is( scalar @$files, $file_cnt,
"Found correct number of output files" );
- is( $ae->files->[-1], $nix_path,
+
+ ### due to prototypes on is(), if there's no -1 index on
+ ### the array ref, it'll give a fatal exception:
+ ### "Modification of non-creatable array value attempted,
+ ### subscript -1 at -e line 1." So wrap it in do { }
+ is( do { $files->[-1] }, $nix_path,
"Found correct output file '$nix_path'" );
ok( -e $abs_path,
diff -urN perl-5.10.0.orig/lib/Archive/Extract/t/src/x.lzma.packed perl-5.10.0/lib/Archive/Extract/t/src/x.lzma.packed
--- perl-5.10.0.orig/lib/Archive/Extract/t/src/x.lzma.packed 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/lib/Archive/Extract/t/src/x.lzma.packed 2009-03-10 12:34:10.000000000 +0100
@@ -0,0 +1,16 @@
+#########################################################################
+This is a binary file that was packed with the 'uupacktool.pl' which
+is included in the Perl distribution.
+
+To unpack this file use the following command:
+
+ uupacktool.pl -u lib/Archive/Extract/t/src/x.lzma.packed lib/Archive/Extract/t/src/x.lzma
+
+To recreate it use the following command:
+
+ uupacktool.pl -p lib/Archive/Extract/t/src/x.lzma lib/Archive/Extract/t/src/x.lzma.packed
+
+Created at Tue Mar 10 12:34:10 2009
+#########################################################################
+__UU__
+270``@```````````````````
diff -urN perl-5.10.0.orig/lib/Archive/Extract.pm perl-5.10.0/lib/Archive/Extract.pm
--- perl-5.10.0.orig/lib/Archive/Extract.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Archive/Extract.pm 2009-03-10 12:30:20.000000000 +0100
@@ -20,6 +20,10 @@
### VMS may require quoting upper case command options
use constant ON_VMS => $^O eq 'VMS' ? 1 : 0;
+### we can't use this extraction method, because of missing
+### modules/binaries:
+use constant METHOD_NA => [];
+
### If these are changed, update @TYPES and the new() POD
use constant TGZ => 'tgz';
use constant TAR => 'tar';
@@ -28,14 +32,21 @@
use constant BZ2 => 'bz2';
use constant TBZ => 'tbz';
use constant Z => 'Z';
+use constant LZMA => 'lzma';
-use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG];
+use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
+ $_ALLOW_BIN $_ALLOW_PURE_PERL
+ ];
+
+$VERSION = '0.30';
+$PREFER_BIN = 0;
+$WARN = 1;
+$DEBUG = 0;
+$_ALLOW_PURE_PERL = 1; # allow pure perl extractors
+$_ALLOW_BIN = 1; # allow binary extractors
-$VERSION = '0.24';
-$PREFER_BIN = 0;
-$WARN = 1;
-$DEBUG = 0;
-my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z ); # same as all constants
+# same as all constants
+my @Types = ( TGZ, TAR, GZ, ZIP, BZ2, TBZ, Z, LZMA );
local $Params::Check::VERBOSE = $Params::Check::VERBOSE = 1;
@@ -75,6 +86,7 @@
$ae->is_zip; # is it a .zip file?
$ae->is_bz2; # is it a .bz2 file?
$ae->is_tbz; # is it a .tar.bz2 or .tbz file?
+ $ae->is_lzma; # is it a .lzma file?
### absolute path to the archive you provided ###
$ae->archive;
@@ -84,13 +96,14 @@
$ae->bin_gzip # path to /bin/gzip, if found
$ae->bin_unzip # path to /bin/unzip, if found
$ae->bin_bunzip2 # path to /bin/bunzip2 if found
+ $ae->bin_unlzma # path to /bin/unlzma if found
=head1 DESCRIPTION
Archive::Extract is a generic archive extraction mechanism.
It allows you to extract any archive file of the type .tar, .tar.gz,
-.gz, .Z, tar.bz2, .tbz, .bz2 or .zip without having to worry how it
+.gz, .Z, tar.bz2, .tbz, .bz2, .zip or .lzma without having to worry how it
does so, or use different interfaces for each type by using either
perl modules, or commandline tools on your system.
@@ -101,31 +114,35 @@
### see what /bin/programs are available ###
$PROGRAMS = {};
-for my $pgm (qw[tar unzip gzip bunzip2 uncompress]) {
+for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma]) {
$PROGRAMS->{$pgm} = can_run($pgm);
}
### mapping from types to extractor methods ###
-my $Mapping = {
- is_tgz => '_untar',
- is_tar => '_untar',
- is_gz => '_gunzip',
- is_zip => '_unzip',
- is_tbz => '_untar',
- is_bz2 => '_bunzip2',
- is_Z => '_uncompress',
+my $Mapping = { # binary program # pure perl module
+ is_tgz => { bin => '_untar_bin', pp => '_untar_at' },
+ is_tar => { bin => '_untar_bin', pp => '_untar_at' },
+ is_gz => { bin => '_gunzip_bin', pp => '_gunzip_cz' },
+ is_zip => { bin => '_unzip_bin', pp => '_unzip_az' },
+ is_tbz => { bin => '_untar_bin', pp => '_untar_at' },
+ is_bz2 => { bin => '_bunzip2_bin', pp => '_bunzip2_bz2'},
+ is_Z => { bin => '_uncompress_bin', pp => '_gunzip_cz' },
+ is_lzma => { bin => '_unlzma_bin', pp => '_unlzma_cz' },
};
-{
+{ ### use subs so we re-generate array refs etc for the no-overide flags
+ ### if we don't, then we reuse the same arrayref, meaning objects store
+ ### previous errors
my $tmpl = {
- archive => { required => 1, allow => FILE_EXISTS },
- type => { default => '', allow => [ @Types ] },
+ archive => sub { { required => 1, allow => FILE_EXISTS } },
+ type => sub { { default => '', allow => [ @Types ] } },
+ _error_msg => sub { { no_override => 1, default => [] } },
+ _error_msg_long => sub { { no_override => 1, default => [] } },
};
### build accesssors ###
for my $method( keys %$tmpl,
qw[_extractor _gunzip_to files extract_path],
- qw[_error_msg _error_msg_long]
) {
no strict 'refs';
*$method = sub {
@@ -183,6 +200,11 @@
Bzip2 compressed tar file, as produced by, for exmample C</bin/tar -j>.
Corresponds to a C<.tbz> or C<.tar.bz2> suffix.
+=item lzma
+
+Lzma compressed file, as produced by C</bin/lzma>.
+Corresponds to a C<.lzma> suffix.
+
=back
Returns a C<Archive::Extract> object on success, or false on failure.
@@ -193,8 +215,12 @@
sub new {
my $class = shift;
my %hash = @_;
+
+ ### see above why we use subs here and generate the template;
+ ### it's basically to not re-use arrayrefs
+ my %utmpl = map { $_ => $tmpl->{$_}->() } keys %$tmpl;
- my $parsed = check( $tmpl, \%hash ) or return;
+ my $parsed = check( \%utmpl, \%hash ) or return;
### make sure we have an absolute path ###
my $ar = $parsed->{archive} = File::Spec->rel2abs( $parsed->{archive} );
@@ -209,15 +235,18 @@
$ar =~ /.+?\.(?:tbz2?|tar\.bz2?)$/i ? TBZ :
$ar =~ /.+?\.bz2$/i ? BZ2 :
$ar =~ /.+?\.Z$/ ? Z :
+ $ar =~ /.+?\.lzma$/ ? LZMA :
'';
}
- ### don't know what type of file it is ###
- return __PACKAGE__->_error(loc("Cannot determine file type for '%1'",
- $parsed->{archive} )) unless $parsed->{type};
+ bless $parsed, $class;
- return bless $parsed, $class;
+ ### don't know what type of file it is
+ ### XXX this *has* to be an object call, not a package call
+ return $parsed->_error(loc("Cannot determine file type for '%1'",
+ $parsed->{archive} )) unless $parsed->{type};
+ return $parsed;
}
}
@@ -229,11 +258,11 @@
Since C<.gz> files never hold a directory, but only a single file; if
the C<to> argument is an existing directory, the file is extracted
-there, with it's C<.gz> suffix stripped.
+there, with its C<.gz> suffix stripped.
If the C<to> argument is not an existing directory, the C<to> argument
is understood to be a filename, if the archive type is C<gz>.
In the case that you did not specify a C<to> argument, the output
-file will be the name of the archive file, stripped from it's C<.gz>
+file will be the name of the archive file, stripped from its C<.gz>
suffix, in the current working directory.
C<extract> will try a pure perl solution first, and then fall back to
@@ -269,6 +298,10 @@
my $self = shift;
my %hash = @_;
+ ### reset error messages
+ $self->_error_msg( [] );
+ $self->_error_msg_long( [] );
+
my $to;
my $tmpl = {
to => { default => '.', store => \$to }
@@ -283,9 +316,9 @@
### to.
my $dir;
{ ### a foo.gz file
- if( $self->is_gz or $self->is_bz2 or $self->is_Z) {
+ if( $self->is_gz or $self->is_bz2 or $self->is_Z or $self->is_lzma ) {
- my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z)$//i;
+ my $cp = $self->archive; $cp =~ s/\.(?:gz|bz2?|Z|lzma)$//i;
### to is a dir?
if ( -d $to ) {
@@ -330,19 +363,50 @@
### ../lib/Archive/Extract.pm line 742. (rt #19815)
$self->files( [] );
- ### find what extractor method to use ###
- while( my($type,$method) = each %$Mapping ) {
+ ### find out the dispatch methods needed for this type of
+ ### archive. Do a $self->is_XXX to figure out the type, then
+ ### get the hashref with bin + pure perl dispatchers.
+ my ($map) = map { $Mapping->{$_} } grep { $self->$_ } keys %$Mapping;
+
+ ### add pure perl extractor if allowed & add bin extractor if allowed
+ my @methods;
+ push @methods, $map->{'pp'} if $_ALLOW_PURE_PERL;
+ push @methods, $map->{'bin'} if $_ALLOW_BIN;
+
+ ### reverse it if we prefer bin extractors
+ @methods = reverse @methods if $PREFER_BIN;
- ### call the corresponding method if the type is OK ###
- if( $self->$type) {
- $ok = $self->$method();
- }
+ my($na, $fail);
+ for my $method (@methods) {
+ print "# Extracting with ->$method\n" if $DEBUG;
+
+ my $rv = $self->$method;
+
+ ### a positive extraction
+ if( $rv and $rv ne METHOD_NA ) {
+ print "# Extraction succeeded\n" if $DEBUG;
+ $self->_extractor($method);
+ last;
+
+ ### method is not available
+ } elsif ( $rv and $rv eq METHOD_NA ) {
+ print "# Extraction method not available\n" if $DEBUG;
+ $na++;
+ } else {
+ print "# Extraction method failed\n" if $DEBUG;
+ $fail++;
+ }
}
- ### warn something went wrong if we didn't get an OK ###
- $self->_error(loc("Extract failed, no extractor found"))
- unless $ok;
-
+ ### warn something went wrong if we didn't get an extractor
+ unless( $self->_extractor ) {
+ my $diag = $fail ? loc("Extract failed due to errors") :
+ $na ? loc("Extract failed; no extractors available") :
+ '';
+
+ $self->_error($diag);
+ $ok = 0;
+ }
}
### and chdir back ###
@@ -418,6 +482,11 @@
Returns true if the file is of type C<.zip>.
See the C<new()> method for details.
+=head2 $ae->is_lzma
+
+Returns true if the file is of type C<.lzma>.
+See the C<new()> method for details.
+
=cut
### quick check methods ###
@@ -428,6 +497,7 @@
sub is_tbz { return $_[0]->type eq TBZ }
sub is_bz2 { return $_[0]->type eq BZ2 }
sub is_Z { return $_[0]->type eq Z }
+sub is_lzma { return $_[0]->type eq LZMA }
=pod
@@ -443,6 +513,10 @@
Returns the full path to your unzip binary, if found
+=head2 $ae->bin_unlzma
+
+Returns the full path to your unlzma binary, if found
+
=cut
### paths to commandline tools ###
@@ -452,6 +526,8 @@
sub bin_bunzip2 { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
sub bin_uncompress { return $PROGRAMS->{'uncompress'}
if $PROGRAMS->{'uncompress'} }
+sub bin_unlzma { return $PROGRAMS->{'unlzma'} if $PROGRAMS->{'unlzma'} }
+
=head2 $bool = $ae->have_old_bunzip2
Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
@@ -478,8 +554,16 @@
### $ echo $?
### 1
### HATEFUL!
+
+ ### double hateful: bunzip2 --version also hangs if input is a pipe
+ ### See #32370: Archive::Extract will hang if stdin is a pipe [+PATCH]
+ ### So, we have to provide *another* argument which is a fake filename,
+ ### just so it wont try to read from stdin to print its version..
+ ### *sigh*
+ ### Even if the file exists, it won't clobber or change it.
my $buffer;
- scalar run( command => [$self->bin_bunzip2, '--version'],
+ scalar run(
+ command => [$self->bin_bunzip2, '--version', 'NoSuchFile'],
verbose => 0,
buffer => \$buffer
);
@@ -500,43 +584,31 @@
#################################
-### untar wrapper... goes to either Archive::Tar or /bin/tar
-### depending on $PREFER_BIN
-sub _untar {
- my $self = shift;
-
- ### bzip2 support in A::T via IO::Uncompress::Bzip2
- my @methods = qw[_untar_at _untar_bin];
- @methods = reverse @methods if $PREFER_BIN;
-
- for my $method (@methods) {
- $self->_extractor($method) && return 1 if $self->$method();
- }
-
- return $self->_error(loc("Unable to untar file '%1'", $self->archive));
-}
-
### use /bin/tar to extract ###
sub _untar_bin {
my $self = shift;
### check for /bin/tar ###
- return $self->_error(loc("No '%1' program found", '/bin/tar'))
- unless $self->bin_tar;
-
### check for /bin/gzip if we need it ###
- return $self->_error(loc("No '%1' program found", '/bin/gzip'))
- if $self->is_tgz && !$self->bin_gzip;
-
- return $self->_error(loc("No '%1' program found", '/bin/bunzip2'))
- if $self->is_tbz && !$self->bin_bunzip2;
+ ### if any of the binaries are not available, return NA
+ { my $diag = not $self->bin_tar ?
+ loc("No '%1' program found", '/bin/tar') :
+ $self->is_tgz && !$self->bin_gzip ?
+ loc("No '%1' program found", '/bin/gzip') :
+ $self->is_tbz && !$self->bin_bunzip2 ?
+ loc("No '%1' program found", '/bin/bunzip2') :
+ '';
+
+ if( $diag ) {
+ $self->_error( $diag );
+ return METHOD_NA;
+ }
+ }
### XXX figure out how to make IPC::Run do this in one call --
### currently i don't know how to get output of a command after a pipe
### trapped in a scalar. Mailed barries about this 5th of june 2004.
-
-
### see what command we should run, based on whether
### it's a .tgz or .tar
@@ -620,14 +692,25 @@
sub _untar_at {
my $self = shift;
- ### we definitely need A::T, so load that first
+ ### Loading Archive::Tar is going to set it to 1, so make it local
+ ### within this block, starting with its initial value. Whatever
+ ### Achive::Tar does will be undone when we return.
+ ###
+ ### Also, later, set $Archive::Tar::WARN to $Archive::Extract::WARN
+ ### so users don't have to even think about this variable. If they
+ ### do, they still get their set value outside of this call.
+ local $Archive::Tar::WARN = $Archive::Tar::WARN;
+
+ ### we definitely need Archive::Tar, so load that first
{ my $use_list = { 'Archive::Tar' => '0.0' };
unless( can_load( modules => $use_list ) ) {
- return $self->_error(loc("You do not have '%1' installed - " .
- "Please install it as soon as possible.",
- 'Archive::Tar'));
+ $self->_error(loc("You do not have '%1' installed - " .
+ "Please install it as soon as possible.",
+ 'Archive::Tar'));
+
+ return METHOD_NA;
}
}
@@ -644,18 +727,24 @@
unless( can_load( modules => $use_list ) ) {
my $which = join '/', sort keys %$use_list;
- return $self->_error(loc(
- "You do not have '%1' installed - Please ".
- "install it as soon as possible.", $which));
-
+ $self->_error(loc(
+ "You do not have '%1' installed - Please ".
+ "install it as soon as possible.", $which)
+ );
+
+ return METHOD_NA;
}
+
} elsif ( $self->is_tbz ) {
my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
unless( can_load( modules => $use_list ) ) {
- return $self->_error(loc(
- "You do not have '%1' installed - Please " .
- "install it as soon as possible.",
- 'IO::Uncompress::Bunzip2'));
+ $self->_error(loc(
+ "You do not have '%1' installed - Please " .
+ "install it as soon as possible.",
+ 'IO::Uncompress::Bunzip2')
+ );
+
+ return METHOD_NA;
}
my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
@@ -666,6 +755,10 @@
$fh_to_read = $bz;
}
+ ### $Archive::Tar::WARN is 1 by default in Archive::Tar, but we've
+ ### localized $Archive::Tar::WARN already.
+ $Archive::Tar::WARN = $Archive::Extract::WARN;
+
my $tar = Archive::Tar->new();
### only tell it it's compressed if it's a .tgz, as we give it a file
@@ -684,8 +777,8 @@
*Archive::Tar::chown = sub {};
}
- ### for version of archive::tar > 1.04
- local $Archive::Tar::Constant::CHOWN = 0;
+ ### for version of Archive::Tar > 1.04
+ local $Archive::Tar::CHOWN = 0;
{ local $^W; # quell 'splice() offset past end of array' warnings
# on older versions of A::T
@@ -720,28 +813,14 @@
#
#################################
-### gunzip wrapper... goes to either Compress::Zlib or /bin/gzip
-### depending on $PREFER_BIN
-sub _gunzip {
- my $self = shift;
-
- my @methods = qw[_gunzip_cz _gunzip_bin];
- @methods = reverse @methods if $PREFER_BIN;
-
- for my $method (@methods) {
- $self->_extractor($method) && return 1 if $self->$method();
- }
-
- return $self->_error(loc("Unable to gunzip file '%1'", $self->archive));
-}
-
sub _gunzip_bin {
my $self = shift;
### check for /bin/gzip -- we need it ###
- return $self->_error(loc("No '%1' program found", '/bin/gzip'))
- unless $self->bin_gzip;
-
+ unless( $self->bin_gzip ) {
+ $self->_error(loc("No '%1' program found", '/bin/gzip'));
+ return METHOD_NA;
+ }
my $fh = FileHandle->new('>'. $self->_gunzip_to) or
return $self->_error(loc("Could not open '%1' for writing: %2",
@@ -779,8 +858,9 @@
my $use_list = { 'Compress::Zlib' => '0.0' };
unless( can_load( modules => $use_list ) ) {
- return $self->_error(loc("You do not have '%1' installed - Please " .
- "install it as soon as possible.", 'Compress::Zlib'));
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Compress::Zlib'));
+ return METHOD_NA;
}
my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
@@ -808,29 +888,14 @@
#
#################################
-
-### untar wrapper... goes to either Archive::Tar or /bin/tar
-### depending on $PREFER_BIN
-sub _uncompress {
- my $self = shift;
-
- my @methods = qw[_gunzip_cz _uncompress_bin];
- @methods = reverse @methods if $PREFER_BIN;
-
- for my $method (@methods) {
- $self->_extractor($method) && return 1 if $self->$method();
- }
-
- return $self->_error(loc("Unable to untar file '%1'", $self->archive));
-}
-
sub _uncompress_bin {
my $self = shift;
### check for /bin/gzip -- we need it ###
- return $self->_error(loc("No '%1' program found", '/bin/uncompress'))
- unless $self->bin_uncompress;
-
+ unless( $self->bin_uncompress ) {
+ $self->_error(loc("No '%1' program found", '/bin/uncompress'));
+ return METHOD_NA;
+ }
my $fh = FileHandle->new('>'. $self->_gunzip_to) or
return $self->_error(loc("Could not open '%1' for writing: %2",
@@ -870,28 +935,15 @@
#
#################################
-### unzip wrapper... goes to either Archive::Zip or /bin/unzip
-### depending on $PREFER_BIN
-sub _unzip {
- my $self = shift;
-
- my @methods = qw[_unzip_az _unzip_bin];
- @methods = reverse @methods if $PREFER_BIN;
-
- for my $method (@methods) {
- $self->_extractor($method) && return 1 if $self->$method();
- }
-
- return $self->_error(loc("Unable to gunzip file '%1'", $self->archive));
-}
sub _unzip_bin {
my $self = shift;
### check for /bin/gzip if we need it ###
- return $self->_error(loc("No '%1' program found", '/bin/unzip'))
- unless $self->bin_unzip;
-
+ unless( $self->bin_unzip ) {
+ $self->_error(loc("No '%1' program found", '/bin/unzip'));
+ return METHOD_NA;
+ }
### first, get the files.. it must be 2 different commands with 'unzip' :(
{ ### on VMS, capital letter options have to be quoted. This is
@@ -946,8 +998,9 @@
my $use_list = { 'Archive::Zip' => '0.0' };
unless( can_load( modules => $use_list ) ) {
- return $self->_error(loc("You do not have '%1' installed - Please " .
- "install it as soon as possible.", 'Archive::Zip'));
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Archive::Zip'));
+ return METHOD_NA;
}
my $zip = Archive::Zip->new();
@@ -1023,27 +1076,14 @@
#
#################################
-### bunzip2 wrapper...
-sub _bunzip2 {
- my $self = shift;
-
- my @methods = qw[_bunzip2_cz2 _bunzip2_bin];
- @methods = reverse @methods if $PREFER_BIN;
-
- for my $method (@methods) {
- $self->_extractor($method) && return 1 if $self->$method();
- }
-
- return $self->_error(loc("Unable to bunzip2 file '%1'", $self->archive));
-}
-
sub _bunzip2_bin {
my $self = shift;
### check for /bin/gzip -- we need it ###
- return $self->_error(loc("No '%1' program found", '/bin/bunzip2'))
- unless $self->bin_bunzip2;
-
+ unless( $self->bin_bunzip2 ) {
+ $self->_error(loc("No '%1' program found", '/bin/bunzip2'));
+ return METHOD_NA;
+ }
my $fh = FileHandle->new('>'. $self->_gunzip_to) or
return $self->_error(loc("Could not open '%1' for writing: %2",
@@ -1116,14 +1156,15 @@
# return 1;
# }
-sub _bunzip2_cz2 {
+sub _bunzip2_bz2 {
my $self = shift;
my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
unless( can_load( modules => $use_list ) ) {
- return $self->_error(loc("You do not have '%1' installed - Please " .
- "install it as soon as possible.",
- 'IO::Uncompress::Bunzip2'));
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.",
+ 'IO::Uncompress::Bunzip2'));
+ return METHOD_NA;
}
IO::Uncompress::Bunzip2::bunzip2($self->archive => $self->_gunzip_to)
@@ -1141,6 +1182,84 @@
#################################
#
+# unlzma code
+#
+#################################
+
+sub _unlzma_bin {
+ my $self = shift;
+
+ ### check for /bin/unlzma -- we need it ###
+ unless( $self->bin_unlzma ) {
+ $self->_error(loc("No '%1' program found", '/bin/unlzma'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $cmd = [ $self->bin_unlzma, '-c', $self->archive ];
+
+ my $buffer;
+ unless( scalar run( command => $cmd,
+ verbose => $DEBUG,
+ buffer => \$buffer )
+ ) {
+ return $self->_error(loc("Unable to unlzma '%1': %2",
+ $self->archive, $buffer));
+ }
+
+ ### no buffers available?
+ if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
+ $self->_error( $self->_no_buffer_content( $self->archive ) );
+ }
+
+ print $fh $buffer if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+sub _unlzma_cz {
+ my $self = shift;
+
+ my $use_list = { 'Compress::unLZMA' => '0.0' };
+ unless( can_load( modules => $use_list ) ) {
+ $self->_error(loc("You do not have '%1' installed - Please " .
+ "install it as soon as possible.", 'Compress::unLZMA'));
+ return METHOD_NA;
+ }
+
+ my $fh = FileHandle->new('>'. $self->_gunzip_to) or
+ return $self->_error(loc("Could not open '%1' for writing: %2",
+ $self->_gunzip_to, $! ));
+
+ my $buffer;
+ $buffer = Compress::unLZMA::uncompressfile( $self->archive );
+ unless ( defined $buffer ) {
+ return $self->_error(loc("Could not unlzma '%1': %2",
+ $self->archive, $@));
+ }
+
+ print $fh $buffer if defined $buffer;
+
+ close $fh;
+
+ ### set what files where extract, and where they went ###
+ $self->files( [$self->_gunzip_to] );
+ $self->extract_path( File::Spec->rel2abs(cwd()) );
+
+ return 1;
+}
+
+#################################
+#
# Error code
#
#################################
@@ -1148,14 +1267,15 @@
sub _error {
my $self = shift;
my $error = shift;
-
- $self->_error_msg( $error );
- $self->_error_msg_long( Carp::longmess($error) );
+ my $lerror = Carp::longmess($error);
+
+ push @{$self->_error_msg}, $error;
+ push @{$self->_error_msg_long}, $lerror;
### set $Archive::Extract::WARN to 0 to disable printing
### of errors
if( $WARN ) {
- carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
+ carp $DEBUG ? $lerror : $error;
}
return;
@@ -1163,7 +1283,15 @@
sub error {
my $self = shift;
- return shift() ? $self->_error_msg_long : $self->_error_msg;
+
+ ### make sure we have a fallback aref
+ my $aref = do {
+ shift()
+ ? $self->_error_msg_long
+ : $self->_error_msg
+ } || [];
+
+ return join $/, @$aref;
}
sub _no_buffer_files {
@@ -1208,7 +1336,7 @@
C<Archive::Extract> can use either pure perl modules or command line
programs under the hood. Some of the pure perl modules (like
-C<Archive::Tar> take the entire contents of the archive into memory,
+C<Archive::Tar> and Compress::unLZMA) take the entire contents of the archive into memory,
which may not be feasible on your system. Consider setting the global
variable C<$Archive::Extract::PREFER_BIN> to C<1>, which will prefer
the use of command line programs and won't consume so much memory.
--- perl-5.10.0.orig/MANIFEST 2009-02-20 18:22:32.000000000 +0100
+++ perl-5.10.0/MANIFEST 2009-03-10 15:16:45.000000000 +0100
@@ -1390,6 +1390,7 @@
lib/Archive/Extract/t/src/x.bz2.packed Archive::Extract tests
lib/Archive/Extract/t/src/x.gz.packed Archive::Extract tests
lib/Archive/Extract/t/src/x.jar.packed Archive::Extract tests
+lib/Archive/Extract/t/src/x.lzma.packed Archive::Extract tests
lib/Archive/Extract/t/src/x.par.packed Archive::Extract tests
lib/Archive/Extract/t/src/x.tar.gz.packed Archive::Extract tests
lib/Archive/Extract/t/src/x.tar.packed Archive::Extract tests

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -1,248 +0,0 @@
Digest-SHA-5.47
- minus the move of SHA.pm from topdir to lib/Digest
(and the induced changes to *.t files and Makefile.PL
diff -urN perl-5.10.0.orig/ext/Digest/SHA/Changes perl-5.10.0/ext/Digest/SHA/Changes
--- perl-5.10.0.orig/ext/Digest/SHA/Changes 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/Changes 2009-03-23 16:33:05.000000000 +0100
@@ -1,5 +1,21 @@
Revision history for Perl extension Digest::SHA.
+5.47 Wed Apr 30 04:00:54 MST 2008
+ - modified Makefile.PL to install in core for Perls >= 5.10
+ -- thanks to Jerry Hedden for patch
+ - changed from #include <> to #include "" in SHA.xs
+ -- some platforms not able to find SHA source files
+ -- thanks to Alexandr Ciornii for testing
+ - moved .pm file to appropriate lib directory
+ - minor addition to META.yml
+
+5.46 Wed Apr 9 05:04:00 MST 2008
+ - modified Addfile to recognize leading and trailing
+ whitespace in filenames (ref. rt.cpan.org #34690)
+ - minor C source code modification (ref. hmac.c)
+ - use const in sha.c for clean builds with -Wwrite-strings
+ -- thanks to Robin Barker for patch
+
5.45 Tue Jun 26 02:36:00 MST 2007
- extended portability to earlier Perls
-- works on Perl 5.003 and later
diff -urN perl-5.10.0.orig/ext/Digest/SHA/README perl-5.10.0/ext/Digest/SHA/README
--- perl-5.10.0.orig/ext/Digest/SHA/README 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/README 2009-03-23 16:33:05.000000000 +0100
@@ -1,4 +1,4 @@
-Digest::SHA version 5.45
+Digest::SHA version 5.47
========================
Digest::SHA is a complete implementation of the NIST Secure Hash
@@ -34,7 +34,7 @@
COPYRIGHT AND LICENSE
-Copyright (C) 2003-2007 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 -urN perl-5.10.0.orig/ext/Digest/SHA/SHA.pm perl-5.10.0/ext/Digest/SHA/SHA.pm
--- perl-5.10.0.orig/ext/Digest/SHA/SHA.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/SHA.pm 2009-03-23 16:33:05.000000000 +0100
@@ -6,7 +6,7 @@
use integer;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = '5.45';
+$VERSION = '5.47';
require Exporter;
require DynaLoader;
@@ -114,7 +114,10 @@
my $text = -T $file;
local *FH;
- open(FH, "<$file") or _bail("Open failed");
+ # 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 && $text) {
@@ -496,9 +499,9 @@
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; on the other
-hand, binary files are read in raw mode with no translation whatsoever.
+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.
For a fuller discussion of newline formats, refer to CPAN module
L<File::LocalizeNewlines>. Its "universal line separator" regex forms
@@ -637,6 +640,7 @@
Gisle Aas
Chris Carey
+ Alexandr Ciornii
Jim Doble
Julius Duque
Jeffrey Friedl
@@ -655,7 +659,7 @@
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2003-2007 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 -urN perl-5.10.0.orig/ext/Digest/SHA/SHA.xs perl-5.10.0/ext/Digest/SHA/SHA.xs
--- perl-5.10.0.orig/ext/Digest/SHA/SHA.xs 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/SHA.xs 2009-03-23 16:33:05.000000000 +0100
@@ -2,8 +2,8 @@
#include "perl.h"
#include "XSUB.h"
-#include <src/sha.c>
-#include <src/hmac.c>
+#include "src/sha.c"
+#include "src/hmac.c"
static int ix2alg[] =
{1,1,1,224,224,224,256,256,256,384,384,384,512,512,512};
@@ -12,8 +12,8 @@
PROTOTYPES: ENABLE
-#include <src/sha.h>
-#include <src/hmac.h>
+#include "src/sha.h"
+#include "src/hmac.h"
#ifndef INT2PTR
#define INT2PTR(p, i) (p) (i)
diff -urN perl-5.10.0.orig/ext/Digest/SHA/bin/shasum perl-5.10.0/ext/Digest/SHA/bin/shasum
--- perl-5.10.0.orig/ext/Digest/SHA/bin/shasum 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/bin/shasum 2009-03-23 16:33:05.000000000 +0100
@@ -2,10 +2,10 @@
# shasum: filter for computing SHA digests (analogous to sha1sum)
#
- # Copyright (C) 2003-2007 Mark Shelor, All Rights Reserved
+ # Copyright (C) 2003-2008 Mark Shelor, All Rights Reserved
#
- # Version: 5.45
- # Tue Jun 26 02:36:00 MST 2007
+ # Version: 5.47
+ # Wed Apr 30 04:00:54 MST 2008
=head1 NAME
@@ -61,7 +61,7 @@
=head1 AUTHOR
-Copyright (c) 2003-2007 Mark Shelor <mshelor@cpan.org>.
+Copyright (c) 2003-2008 Mark Shelor <mshelor@cpan.org>.
=head1 SEE ALSO
@@ -74,7 +74,7 @@
use FileHandle;
use Getopt::Long;
-my $VERSION = "5.45";
+my $VERSION = "5.47";
# Try to use Digest::SHA, since it's faster. If not installed,
diff -urN perl-5.10.0.orig/ext/Digest/SHA/src/hmac.c perl-5.10.0/ext/Digest/SHA/src/hmac.c
--- perl-5.10.0.orig/ext/Digest/SHA/src/hmac.c 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/src/hmac.c 2009-03-23 16:33:05.000000000 +0100
@@ -3,10 +3,10 @@
*
* Ref: FIPS PUB 198 The Keyed-Hash Message Authentication Code
*
- * Copyright (C) 2003-2007 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2008 Mark Shelor, All Rights Reserved
*
- * Version: 5.45
- * Tue Jun 26 02:36:00 MST 2007
+ * Version: 5.47
+ * Wed Apr 30 04:00:54 MST 2008
*
*/
@@ -94,8 +94,8 @@
/* hmacclose: de-allocates digest object */
int hmacclose(HMAC *h)
{
- shaclose(h->osha);
if (h != NULL) {
+ shaclose(h->osha);
memset(h, 0, sizeof(HMAC));
SHA_free(h);
}
diff -urN perl-5.10.0.orig/ext/Digest/SHA/src/hmac.h perl-5.10.0/ext/Digest/SHA/src/hmac.h
--- perl-5.10.0.orig/ext/Digest/SHA/src/hmac.h 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/src/hmac.h 2009-03-23 16:33:05.000000000 +0100
@@ -3,10 +3,10 @@
*
* Ref: FIPS PUB 198 The Keyed-Hash Message Authentication Code
*
- * Copyright (C) 2003-2007 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2008 Mark Shelor, All Rights Reserved
*
- * Version: 5.45
- * Tue Jun 26 02:36:00 MST 2007
+ * Version: 5.47
+ * Wed Apr 30 04:00:54 MST 2008
*
*/
diff -urN perl-5.10.0.orig/ext/Digest/SHA/src/sha.c perl-5.10.0/ext/Digest/SHA/src/sha.c
--- perl-5.10.0.orig/ext/Digest/SHA/src/sha.c 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/src/sha.c 2009-03-23 16:33:05.000000000 +0100
@@ -3,10 +3,10 @@
*
* Ref: NIST FIPS PUB 180-2 Secure Hash Standard
*
- * Copyright (C) 2003-2007 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2008 Mark Shelor, All Rights Reserved
*
- * Version: 5.45
- * Tue Jun 26 02:36:00 MST 2007
+ * Version: 5.47
+ * Wed Apr 30 04:00:54 MST 2008
*
*/
@@ -560,7 +560,7 @@
/* ldvals: checks next line in dump file against tag, and loads values */
static int ldvals(
SHA_FILE *f,
- char *tag,
+ const char *tag,
int type,
void *pval,
int reps,
diff -urN perl-5.10.0.orig/ext/Digest/SHA/src/sha.h perl-5.10.0/ext/Digest/SHA/src/sha.h
--- perl-5.10.0.orig/ext/Digest/SHA/src/sha.h 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Digest/SHA/src/sha.h 2009-03-23 16:33:05.000000000 +0100
@@ -3,10 +3,10 @@
*
* Ref: NIST FIPS PUB 180-2 Secure Hash Standard
*
- * Copyright (C) 2003-2007 Mark Shelor, All Rights Reserved
+ * Copyright (C) 2003-2008 Mark Shelor, All Rights Reserved
*
- * Version: 5.45
- * Tue Jun 26 02:36:00 MST 2007
+ * Version: 5.47
+ * Wed Apr 30 04:00:54 MST 2008
*
*/

View File

@ -1,371 +0,0 @@
File-Fetch-0.18
diff -urN perl-5.10.0.orig/lib/File/Fetch/t/01_File-Fetch.t perl-5.10.0/lib/File/Fetch/t/01_File-Fetch.t
--- perl-5.10.0.orig/lib/File/Fetch/t/01_File-Fetch.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Fetch/t/01_File-Fetch.t 2009-03-10 14:28:48.000000000 +0100
@@ -22,7 +22,7 @@
Some of these tests assume you are connected to the
internet. If you are not, or if certain protocols or hosts
-are blocked and/or firewalled, these tests will fail due
+are blocked and/or firewalled, these tests could fail due
to no fault of the module itself.
###########################################################
@@ -115,6 +115,13 @@
) if &File::Fetch::ON_WIN;
+### sanity tests
+{ like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/,
+ "User agent contains version" );
+ like( $File::Fetch::FROM_EMAIL, qr/@/,
+ q[Email contains '@'] );
+}
+
### parse uri tests ###
for my $entry (@map ) {
my $uri = $entry->{'uri'};
@@ -148,14 +155,14 @@
my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///';
my $uri = $prefix . cwd() .'/'. basename($0);
- for (qw[lwp file]) {
+ for (qw[lwp lftp file]) {
_fetch_uri( file => $uri, $_ );
}
}
### ftp:// tests ###
{ my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html';
- for (qw[lwp netftp wget curl ncftp]) {
+ for (qw[lwp netftp wget curl lftp ncftp]) {
### STUPID STUPID warnings ###
next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE
@@ -167,9 +174,10 @@
### http:// tests ###
{ for my $uri ( 'http://www.cpan.org/index.html',
- 'http://www.cpan.org/index.html?q=1&y=2'
+ 'http://www.cpan.org/index.html?q=1',
+ 'http://www.cpan.org/index.html?q=1&y=2',
) {
- for (qw[lwp wget curl lynx]) {
+ for (qw[lwp wget curl lftp lynx]) {
_fetch_uri( http => $uri, $_ );
}
}
@@ -206,6 +214,11 @@
skip "You do not have '$method' installed/available", 3
if $File::Fetch::METHOD_FAIL->{$method} &&
$File::Fetch::METHOD_FAIL->{$method};
+
+ ### if the file wasn't fetched, it may be a network/firewall issue
+ skip "Fetch failed; no network connectivity for '$type'?", 3
+ unless $file;
+
ok( $file, " File ($file) fetched with $method ($uri)" );
ok( $file && -s $file,
" File has size" );
diff -urN perl-5.10.0.orig/lib/File/Fetch.pm perl-5.10.0/lib/File/Fetch.pm
--- perl-5.10.0.orig/lib/File/Fetch.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Fetch.pm 2009-03-10 14:29:10.000000000 +0100
@@ -2,6 +2,7 @@
use strict;
use FileHandle;
+use File::Temp;
use File::Copy;
use File::Spec;
use File::Spec::Unix;
@@ -9,7 +10,7 @@
use Cwd qw[cwd];
use Carp qw[carp];
-use IPC::Cmd qw[can_run run];
+use IPC::Cmd qw[can_run run QUOTE];
use File::Path qw[mkpath];
use Params::Check qw[check];
use Module::Load::Conditional qw[can_load];
@@ -20,14 +21,11 @@
$FTP_PASSIVE $TIMEOUT $DEBUG $WARN
];
-use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] };
-
-
-$VERSION = '0.14';
+$VERSION = '0.18';
$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';
+$USER_AGENT = "File::Fetch/$VERSION";
$BLACKLIST = [qw|ftp|];
$METHOD_FAIL = { };
$FTP_PASSIVE = 1;
@@ -37,9 +35,9 @@
### methods available to fetch the file depending on the scheme
$METHODS = {
- http => [ qw|lwp wget curl lynx| ],
- ftp => [ qw|lwp netftp wget curl ncftp ftp| ],
- file => [ qw|lwp file| ],
+ http => [ qw|lwp wget curl lftp lynx| ],
+ ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
+ file => [ qw|lwp lftp file| ],
rsync => [ qw|rsync| ]
};
@@ -50,11 +48,13 @@
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_UNIX => (!ON_WIN);
-use constant HAS_VOL => (ON_WIN);
-use constant HAS_SHARE => (ON_WIN);
+use constant ON_WIN => ($^O eq 'MSWin32');
+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);
+
+
=pod
=head1 NAME
@@ -146,7 +146,7 @@
##########################
{
- ### template for new() and autogenerated accessors ###
+ ### template for autogenerated accessors ###
my $Tmpl = {
scheme => { default => 'http' },
host => { default => 'localhost' },
@@ -626,11 +626,14 @@
push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
### set the output document, add the uri ###
- push @$cmd, '--output-document',
- ### 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, '--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);
### shell out ###
my $captured;
@@ -653,6 +656,81 @@
}
}
+### /bin/lftp fetch ###
+sub _lftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a wget binary ###
+ if( my $lftp = can_run('lftp') ) {
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $lftp, '-f' ];
+
+ my $fh = File::Temp->new;
+
+ my $str;
+
+ ### 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;
+
+ ### 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";
+ }
+
+ ### 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;
+
+ ### 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;
+
+ } else {
+ $METHOD_FAIL->{'lftp'} = 1;
+ return;
+ }
+}
+
+
### /bin/ftp fetch ###
sub _ftp_fetch {
@@ -717,6 +795,33 @@
'lynx' ));
}
+ ### check if the HTTP resource exists ###
+ if ($self->uri =~ /^https?:\/\//i) {
+ my $cmd = [
+ $lynx,
+ '-head',
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
+
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+
+ push @$cmd, $self->uri;
+
+ ### shell out ###
+ my $head;
+ unless(run( command => $cmd,
+ buffer => \$head,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+
+ 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(
@@ -732,9 +837,14 @@
push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $IPC::Cmd::USE_IPC_RUN
- ? $self->uri
- : QUOTE. $self->uri .QUOTE;
+ 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 ###
@@ -829,7 +939,7 @@
if (my $curl = can_run('curl')) {
### these long opts are self explanatory - I like that -jmb
- my $cmd = [ $curl ];
+ my $cmd = [ $curl, '-q' ];
push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
@@ -842,11 +952,15 @@
### curl doesn't follow 302 (temporarily moved) etc automatically
### so we add --location to enable that.
- push @$cmd, '--fail', '--location', '--output',
- ### 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, '--fail', '--location', '--output', $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);
+
my $captured;
unless(run( command => $cmd,
@@ -960,9 +1074,14 @@
push(@$cmd, '--quiet') unless $DEBUG;
### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $IPC::Cmd::USE_IPC_RUN
- ? ($self->uri, $to)
- : (QUOTE. $self->uri .QUOTE, QUOTE. $to .QUOTE);
+ 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,
@@ -1030,9 +1149,9 @@
Below is a mapping of what utilities will be used in what order
for what schemes, if available:
- file => LWP, file
- http => LWP, wget, curl, lynx
- ftp => LWP, Net::FTP, wget, curl, ncftp, ftp
+ file => LWP, lftp, file
+ http => LWP, wget, curl, lftp, lynx
+ ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
rsync => rsync
If you'd like to disable the use of one or more of these utilities
@@ -1148,6 +1267,7 @@
ftp => ftp
curl => curl
rsync => rsync
+ lftp => lftp
=head1 FREQUENTLY ASKED QUESTIONS

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -1,788 +0,0 @@
Module-CoreList-2.17
diff -urN perl-5.10.0.orig/lib/Module/CoreList/bin/corelist perl-5.10.0/lib/Module/CoreList/bin/corelist
--- perl-5.10.0.orig/lib/Module/CoreList/bin/corelist 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Module/CoreList/bin/corelist 2009-02-10 11:51:46.000000000 +0100
@@ -11,14 +11,14 @@
=head1 SYNOPSIS
corelist -v
- corelist [-a] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
+ corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
=head1 OPTIONS
=over
-=item -a modulename
+=item -a
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.
@@ -44,6 +44,11 @@
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 -? or -help
help! help! help! to see more help, try --man.
@@ -79,7 +84,7 @@
my %Opts;
-GetOptions(\%Opts, qw[ help|?! man! v|version:f a! ] );
+GetOptions(\%Opts, qw[ help|?! man! v|version:f a! d ] );
pod2usage(1) if $Opts{help};
pod2usage(-verbose=>2) if $Opts{man};
@@ -93,15 +98,16 @@
}
$Opts{v} = numify_version( $Opts{v} );
- if( !exists $Module::CoreList::version{$Opts{v}} ) {
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if( !$version_hash ) {
print "\nModule::CoreList has no info on perl v$Opts{v}\n\n";
exit 1;
}
if ( !@ARGV ) {
print "\nThe following modules were in perl v$Opts{v} CORE\n";
- print "$_ ", $Module::CoreList::version{$Opts{v}}{$_} || " ","\n"
- for sort keys %{$Module::CoreList::version{$Opts{v}}};
+ print "$_ ", $version_hash->{$_} || " ","\n"
+ for sort keys %$version_hash;
print "\n";
exit 0;
}
@@ -149,12 +155,17 @@
my($mod,$ver) = @_;
if ( $Opts{v} ) {
- return printf " %-24s %-10s\n",
- $mod,
- $Module::CoreList::version{$Opts{v}}{$mod} || 'undef';
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if ($version_hash) {
+ print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
+ return;
+ }
+ else { die "Shouldn't happen" }
}
- my $ret = Module::CoreList->first_release(@_);
+ my $ret = $Opts{d}
+ ? Module::CoreList->first_release_by_date(@_)
+ : Module::CoreList->first_release(@_);
my $msg = $mod;
$msg .= " $ver" if $ver;
@@ -184,13 +195,12 @@
sub numify_version {
my $ver = shift;
- if ( index( $ver, q{.}, index( $ver, q{.} ) ) >= 0 ) {
- eval { require version };
- if ($@) {
- die "You need to install version.pm to use dotted version numbers\n";
- }
+ if ($ver =~ /\..+\./) {
+ eval { require version ; 1 }
+ or die "You need to install version.pm to use dotted version numbers\n";
$ver = version->new($ver)->numify;
}
+ $ver += 0;
return $ver;
}
diff -urN perl-5.10.0.orig/lib/Module/CoreList.pm perl-5.10.0/lib/Module/CoreList.pm
--- perl-5.10.0.orig/lib/Module/CoreList.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Module/CoreList.pm 2009-02-10 11:51:14.000000000 +0100
@@ -1,7 +1,7 @@
package Module::CoreList;
use strict;
use vars qw/$VERSION %released %patchlevel %version %families/;
-$VERSION = '2.13';
+$VERSION = '2.17';
=head1 NAME
@@ -59,7 +59,7 @@
Module::CoreList currently covers the 5.000, 5.001, 5.002, 5.003_07, 5.004,
5.004_05, 5.005, 5.005_03, 5.005_04, 5.6.0, 5.6.1, 5.6.2, 5.7.3, 5.8.0, 5.8.1,
-5.8.2, 5.8.3, 5.8.4, 5.8.5, 5.8.6, 5.8.7, 5.8.8, 5.9.0, 5.9.1, 5.9.2, 5.9.3,
+5.8.2, 5.8.3, 5.8.4, 5.8.5, 5.8.6, 5.8.7, 5.8.8, 5.8.9, 5.9.0, 5.9.1, 5.9.2, 5.9.3,
5.9.4, 5.9.5 and 5.10.0 releases of perl.
=head1 HISTORY
@@ -74,7 +74,7 @@
=head1 COPYRIGHT
-Copyright (C) 2002-2007 Richard Clamp. All Rights Reserved.
+Copyright (C) 2002-2009 Richard Clamp. All Rights Reserved.
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
@@ -138,12 +138,17 @@
return sort keys %mods
}
+sub find_version {
+ my ($class, $v) = @_;
+ return $version{$v} if defined $version{$v};
+ return undef;
+}
# when things escaped
%released = (
5.000 => '1994-10-17',
5.001 => '1995-03-14',
- 5.002 => '1996-02-96',
+ 5.002 => '1996-02-29',
5.00307 => '1996-10-10',
5.004 => '1997-05-15',
5.005 => '1998-07-22',
@@ -170,13 +175,14 @@
5.009004 => '2006-08-15',
5.009005 => '2007-07-07',
5.010000 => '2007-12-18',
+ 5.008009 => '2008-12-14',
);
# perforce branches and patch levels
%patchlevel = (
5.005 => [perl => 1647],
5.00503 => ['maint-5.005' => 3198],
- 5.00405 => ['maint-5.004' => 999],
+ 5.00405 => ['maint-5.004' => 3296],
5.006 => [perl => 5899],
5.006001 => ['maint-5.6' => 9654],
5.006002 => ['maint-5.6' => 21727],
@@ -198,6 +204,7 @@
5.009004 => [perl => 28727],
5.009005 => [perl => 31562],
5.010000 => [perl => 32642],
+ 5.008009 => ['maint-5.8' => 35095],
);
for my $version ( sort { $a <=> $b } keys %released ) {
@@ -1377,6 +1384,7 @@
'ExtUtils::MM_Win32' => undef, #./lib/ExtUtils/MM_Win32.pm
'ExtUtils::MakeMaker' => '5.45', #./lib/ExtUtils/MakeMaker.pm
'ExtUtils::Manifest' => '1.33 ', #./lib/ExtUtils/Manifest.pm
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.14 ', #./lib/ExtUtils/Mkbootstrap.pm
'ExtUtils::Mksymlists' => '1.17 ', #./lib/ExtUtils/Mksymlists.pm
'ExtUtils::Packlist' => '0.03', #./lib/ExtUtils/Packlist.pm
@@ -1601,6 +1609,7 @@
'ExtUtils::Liblist' => 1.26 ,
'ExtUtils::MakeMaker' => 5.45,
'ExtUtils::Manifest' => 1.33 ,
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => 1.14 ,
'ExtUtils::Mksymlists' => 1.17 ,
'ExtUtils::MM_Cygwin' => undef,
@@ -2002,7 +2011,7 @@
'warnings' => undef, #lib/warnings.pm
'warnings::register' => undef, #lib/warnings/register.pm
'XSLoader' => '0.01', #lib/XSLoader.pm
- },
+ },
5.007003 => {
'AnyDBM_File' => '1.00',
@@ -2103,6 +2112,7 @@
'ExtUtils::Liblist' => '1.2701',
'ExtUtils::MakeMaker' => '5.48_03',
'ExtUtils::Manifest' => '1.35',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.1401',
'ExtUtils::Mksymlists' => '1.18',
'ExtUtils::MM_BeOS' => '1.00',
@@ -2424,6 +2434,7 @@
'ExtUtils::Liblist::Kid'=> '1.29', #./lib/ExtUtils/Liblist/Kid.pm
'ExtUtils::MakeMaker' => '6.03', #./lib/ExtUtils/MakeMaker.pm
'ExtUtils::Manifest' => '1.38', #./lib/ExtUtils/Manifest.pm
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.15', #./lib/ExtUtils/Mkbootstrap.pm
'ExtUtils::Mksymlists' => '1.19', #./lib/ExtUtils/Mksymlists.pm
'ExtUtils::MM' => '0.04', #./lib/ExtUtils/MM.pm
@@ -4457,6 +4468,7 @@
'XSLoader' => '0.03', #lib/XSLoader.pm
'XS::Typemap' => '0.01', #lib/XS/Typemap.pm
},
+
5.008004 => {
'AnyDBM_File' => '1.00', #lib/AnyDBM_File.pm
'attributes' => '0.06', #lib/attributes.pm
@@ -5550,6 +5562,7 @@
'XSLoader' => '0.02', #lib/XSLoader.pm
'XS::Typemap' => '0.01', #lib/XS/Typemap.pm
},
+
5.009002 => {
'AnyDBM_File' => '1.00',
'Attribute::Handlers' => '0.78_01',
@@ -5590,6 +5603,7 @@
'Carp::Heavy' => '1.04',
'Class::ISA' => '0.33',
'Class::Struct' => '0.63',
+ 'Config' => undef,
'Config::Extensions' => '0.01',
'Cwd' => '3.05',
'DB' => '1.0',
@@ -5668,6 +5682,7 @@
'ExtUtils::MakeMaker::bytes'=> '0.01',
'ExtUtils::MakeMaker::vmsish'=> '0.01',
'ExtUtils::Manifest' => '1.44',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.15',
'ExtUtils::Mksymlists' => '1.19',
'ExtUtils::Packlist' => '0.04',
@@ -5914,6 +5929,7 @@
'warnings' => '1.04',
'warnings::register' => '1.00',
},
+
5.008007 => {
'AnyDBM_File' => '1.00',
'Attribute::Handlers' => '0.78_01',
@@ -5954,6 +5970,7 @@
'Carp::Heavy' => '1.04',
'Class::ISA' => '0.33',
'Class::Struct' => '0.63',
+ 'Config' => undef,
'Cwd' => '3.05',
'DB' => '1.0',
'DBM_Filter' => '0.01',
@@ -6031,6 +6048,7 @@
'ExtUtils::MakeMaker::bytes'=> '0.01',
'ExtUtils::MakeMaker::vmsish'=> '0.01',
'ExtUtils::Manifest' => '1.42',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.15',
'ExtUtils::Mksymlists' => '1.19',
'ExtUtils::Packlist' => '0.04',
@@ -6273,6 +6291,7 @@
'warnings' => '1.03',
'warnings::register' => '1.00',
},
+
5.009003 => {
'AnyDBM_File' => '1.00',
'Archive::Tar' => '1.26_01',
@@ -6343,6 +6362,7 @@
'Compress::Zlib::ParseParameters'=> '2.000_07',
'Compress::Zlib::UncompressPlugin::Identity'=> '2.000_05',
'Compress::Zlib::UncompressPlugin::Inflate'=> '2.000_05',
+ 'Config' => undef,
'Config::Extensions' => '0.01',
'Cwd' => '3.15',
'DB' => '1.01',
@@ -6438,6 +6458,7 @@
'ExtUtils::MakeMaker::bytes'=> '0.01',
'ExtUtils::MakeMaker::vmsish'=> '0.01',
'ExtUtils::Manifest' => '1.46',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.15',
'ExtUtils::Mksymlists' => '1.19',
'ExtUtils::Packlist' => '0.04',
@@ -6722,6 +6743,7 @@
'warnings' => '1.05',
'warnings::register' => '1.01',
},
+
5.008008 => {
'AnyDBM_File' => '1.00',
'Attribute::Handlers' => '0.78_02',
@@ -6762,6 +6784,7 @@
'Carp::Heavy' => '1.04',
'Class::ISA' => '0.33',
'Class::Struct' => '0.63',
+ 'Config' => undef,
'Cwd' => '3.12',
'DB' => '1.01',
'DBM_Filter' => '0.01',
@@ -6844,6 +6867,7 @@
'ExtUtils::MakeMaker::bytes'=> '0.01',
'ExtUtils::MakeMaker::vmsish'=> '0.01',
'ExtUtils::Manifest' => '1.46',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.15',
'ExtUtils::Mksymlists' => '1.19',
'ExtUtils::Packlist' => '0.04',
@@ -7089,6 +7113,7 @@
'warnings' => '1.05',
'warnings::register' => '1.01',
},
+
5.009004 => {
'AnyDBM_File' => '1.00',
'Archive::Tar' => '1.30_01',
@@ -7138,6 +7163,7 @@
'Class::Struct' => '0.63',
'Compress::Raw::Zlib' => '2.000_13',
'Compress::Zlib' => '2.000_13',
+ 'Config' => undef,
'Config::Extensions' => '0.01',
'Cwd' => '3.19',
'DB' => '1.01',
@@ -7233,6 +7259,7 @@
'ExtUtils::MakeMaker::bytes'=> '0.01',
'ExtUtils::MakeMaker::vmsish'=> '0.01',
'ExtUtils::Manifest' => '1.46_01',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '1.15_01',
'ExtUtils::Mksymlists' => '1.19_01',
'ExtUtils::Packlist' => '1.41',
@@ -7571,6 +7598,7 @@
'warnings' => '1.05',
'warnings::register' => '1.01',
},
+
5.009005 => {
'AnyDBM_File' => '1.00',
'Archive::Extract' => '0.22_01',
@@ -8105,6 +8133,7 @@
'warnings' => '1.06',
'warnings::register' => '1.01',
},
+
5.010000 => {
'AnyDBM_File' => '1.00',
'Archive::Extract' => '0.24',
@@ -8285,6 +8314,7 @@
'ExtUtils::MakeMaker::bytes'=> '6.42',
'ExtUtils::MakeMaker::vmsish'=> '6.42',
'ExtUtils::Manifest' => '1.51_01',
+ 'ExtUtils::Miniperl' => undef,
'ExtUtils::Mkbootstrap' => '6.42',
'ExtUtils::Mksymlists' => '6.42',
'ExtUtils::Packlist' => '1.43',
@@ -8644,7 +8674,418 @@
'warnings' => '1.06',
'warnings::register' => '1.01',
},
+
+ 5.008009 => {
+ 'AnyDBM_File' => '1.00',
+ 'Attribute::Handlers' => '0.78_03',
+ 'AutoLoader' => '5.67',
+ 'AutoSplit' => '1.06',
+ 'B' => '1.19',
+ 'B::Asmdata' => '1.02',
+ 'B::Assembler' => '0.08',
+ 'B::Bblock' => '1.02_01',
+ 'B::Bytecode' => '1.01_01',
+ 'B::C' => '1.05',
+ 'B::CC' => '1.00_01',
+ 'B::Concise' => '0.76',
+ 'B::Debug' => '1.05',
+ 'B::Deparse' => '0.87',
+ 'B::Disassembler' => '1.05',
+ 'B::Lint' => '1.11',
+ 'B::Lint::Debug' => undef,
+ 'B::Showlex' => '1.02',
+ 'B::Stackobj' => '1.00',
+ 'B::Stash' => '1.00',
+ 'B::Terse' => '1.05',
+ 'B::Xref' => '1.01',
+ 'Benchmark' => '1.1',
+ 'ByteLoader' => '0.06',
+ 'CGI' => '3.42',
+ 'CGI::Apache' => '1.00',
+ 'CGI::Carp' => '1.30_01',
+ 'CGI::Cookie' => '1.29',
+ 'CGI::Fast' => '1.07',
+ 'CGI::Pretty' => '1.08',
+ 'CGI::Push' => '1.04',
+ 'CGI::Switch' => '1.00',
+ 'CGI::Util' => '1.5_01',
+ 'CPAN' => '1.9301',
+ 'CPAN::Debug' => '5.5',
+ 'CPAN::DeferedCode' => '5.50',
+ 'CPAN::Distroprefs' => '6',
+ 'CPAN::FirstTime' => '5.5_01',
+ 'CPAN::HandleConfig' => '5.5',
+ 'CPAN::Kwalify' => '5.50',
+ 'CPAN::Nox' => '5.50',
+ 'CPAN::Queue' => '5.5',
+ 'CPAN::Tarzip' => '5.5',
+ 'CPAN::Version' => '5.5',
+ 'Carp' => '1.10',
+ 'Carp::Heavy' => '1.10',
+ 'Class::ISA' => '0.33',
+ 'Class::Struct' => '0.63',
+ 'Config' => undef,
+ 'Cwd' => '3.29',
+ 'DB' => '1.01',
+ 'DBM_Filter' => '0.02',
+ 'DBM_Filter::compress' => '0.02',
+ 'DBM_Filter::encode' => '0.02',
+ 'DBM_Filter::int32' => '0.02',
+ 'DBM_Filter::null' => '0.02',
+ 'DBM_Filter::utf8' => '0.02',
+ 'DB_File' => '1.817',
+ 'DCLsym' => '1.03',
+ 'Data::Dumper' => '2.121_17',
+ 'Devel::DProf' => '20080331.00',
+ 'Devel::InnerPackage' => '0.3',
+ 'Devel::PPPort' => '3.14',
+ 'Devel::Peek' => '1.04',
+ 'Devel::SelfStubber' => '1.03',
+ 'Digest' => '1.15',
+ 'Digest::MD5' => '2.37',
+ 'Digest::base' => '1.00',
+ 'Digest::file' => '1.00',
+ 'DirHandle' => '1.02',
+ 'Dumpvalue' => '1.12',
+ 'DynaLoader' => '1.09',
+ 'Encode' => '2.26',
+ 'Encode::Alias' => '2.10',
+ 'Encode::Byte' => '2.03',
+ 'Encode::CJKConstants' => '2.02',
+ 'Encode::CN' => '2.02',
+ 'Encode::CN::HZ' => '2.05',
+ 'Encode::Config' => '2.05',
+ 'Encode::EBCDIC' => '2.02',
+ 'Encode::Encoder' => '2.01',
+ 'Encode::Encoding' => '2.05',
+ 'Encode::GSM0338' => '2.01',
+ 'Encode::Guess' => '2.02',
+ 'Encode::JP' => '2.03',
+ 'Encode::JP::H2Z' => '2.02',
+ 'Encode::JP::JIS7' => '2.04',
+ 'Encode::KR' => '2.02',
+ 'Encode::KR::2022_KR' => '2.02',
+ 'Encode::MIME::Header' => '2.05',
+ 'Encode::MIME::Header::ISO_2022_JP'=> '1.03',
+ 'Encode::MIME::Name' => '1.01',
+ 'Encode::Symbol' => '2.02',
+ 'Encode::TW' => '2.02',
+ 'Encode::Unicode' => '2.05',
+ 'Encode::Unicode::UTF7' => '2.04',
+ 'English' => '1.03',
+ 'Env' => '1.00',
+ 'Errno' => '1.10',
+ 'Exporter' => '5.63',
+ 'Exporter::Heavy' => '5.63',
+ 'ExtUtils::Command' => '1.15',
+ 'ExtUtils::Command::MM' => '6.48',
+ 'ExtUtils::Constant' => '0.21',
+ 'ExtUtils::Constant::Base'=> '0.04',
+ 'ExtUtils::Constant::ProxySubs'=> '0.06',
+ 'ExtUtils::Constant::Utils'=> '0.02',
+ 'ExtUtils::Constant::XS'=> '0.02',
+ 'ExtUtils::Embed' => '1.28',
+ 'ExtUtils::Install' => '1.50_01',
+ 'ExtUtils::Installed' => '1.43',
+ 'ExtUtils::Liblist' => '6.48',
+ 'ExtUtils::Liblist::Kid'=> '6.48',
+ 'ExtUtils::MM' => '6.48',
+ 'ExtUtils::MM_AIX' => '6.48',
+ 'ExtUtils::MM_Any' => '6.48',
+ 'ExtUtils::MM_BeOS' => '6.48',
+ 'ExtUtils::MM_Cygwin' => '6.48',
+ 'ExtUtils::MM_DOS' => '6.48',
+ 'ExtUtils::MM_Darwin' => '6.48',
+ 'ExtUtils::MM_MacOS' => '6.48',
+ 'ExtUtils::MM_NW5' => '6.48',
+ 'ExtUtils::MM_OS2' => '6.48',
+ 'ExtUtils::MM_QNX' => '6.48',
+ 'ExtUtils::MM_UWIN' => '6.48',
+ 'ExtUtils::MM_Unix' => '6.48',
+ 'ExtUtils::MM_VMS' => '6.48',
+ 'ExtUtils::MM_VOS' => '6.48',
+ 'ExtUtils::MM_Win32' => '6.48',
+ 'ExtUtils::MM_Win95' => '6.48',
+ 'ExtUtils::MY' => '6.48',
+ 'ExtUtils::MakeMaker' => '6.48',
+ 'ExtUtils::MakeMaker::Config'=> '6.48',
+ 'ExtUtils::MakeMaker::bytes'=> '6.48',
+ 'ExtUtils::MakeMaker::vmsish'=> '6.48',
+ 'ExtUtils::Manifest' => '1.55',
+ 'ExtUtils::Miniperl' => undef,
+ 'ExtUtils::Mkbootstrap' => '6.48',
+ 'ExtUtils::Mksymlists' => '6.48',
+ 'ExtUtils::Packlist' => '1.43',
+ 'ExtUtils::ParseXS' => '2.19',
+ 'ExtUtils::testlib' => '6.48',
+ 'Fatal' => '1.06',
+ 'Fcntl' => '1.06',
+ 'File::Basename' => '2.77',
+ 'File::CheckTree' => '4.4',
+ 'File::Compare' => '1.1005',
+ 'File::Copy' => '2.13',
+ 'File::DosGlob' => '1.01',
+ 'File::Find' => '1.13',
+ 'File::Glob' => '1.06',
+ 'File::Path' => '2.07_02',
+ 'File::Spec' => '3.29',
+ 'File::Spec::Cygwin' => '3.29',
+ 'File::Spec::Epoc' => '3.29',
+ 'File::Spec::Functions' => '3.29',
+ 'File::Spec::Mac' => '3.29',
+ 'File::Spec::OS2' => '3.29',
+ 'File::Spec::Unix' => '3.29',
+ 'File::Spec::VMS' => '3.29',
+ 'File::Spec::Win32' => '3.29',
+ 'File::Temp' => '0.20',
+ 'File::stat' => '1.01',
+ 'FileCache' => '1.07',
+ 'FileHandle' => '2.01',
+ 'Filespec' => '1.11',
+ 'Filter::Simple' => '0.83',
+ 'Filter::Util::Call' => '1.07',
+ 'FindBin' => '1.49',
+ 'GDBM_File' => '1.09',
+ 'Getopt::Long' => '2.37',
+ 'Getopt::Std' => '1.06',
+ 'Hash::Util' => '0.06',
+ 'I18N::Collate' => '1.00',
+ 'I18N::LangTags' => '0.35',
+ 'I18N::LangTags::Detect'=> '1.03',
+ 'I18N::LangTags::List' => '0.35',
+ 'I18N::Langinfo' => '0.02',
+ 'IO' => '1.23',
+ 'IO::Dir' => '1.06',
+ 'IO::File' => '1.14',
+ 'IO::Handle' => '1.27',
+ 'IO::Pipe' => '1.13',
+ 'IO::Poll' => '0.07',
+ 'IO::Seekable' => '1.10',
+ 'IO::Select' => '1.17',
+ 'IO::Socket' => '1.30',
+ 'IO::Socket::INET' => '1.31',
+ 'IO::Socket::UNIX' => '1.23',
+ 'IPC::Msg' => '2.00',
+ 'IPC::Open2' => '1.03',
+ 'IPC::Open3' => '1.03',
+ 'IPC::Semaphore' => '2.00',
+ 'IPC::SharedMem' => '2.00',
+ 'IPC::SysV' => '2.00',
+ 'IPC::lib::IPC::Msg' => '2.00',
+ 'IPC::lib::IPC::Semaphore'=> '2.00',
+ 'IPC::lib::IPC::SharedMem'=> '2.00',
+ 'List::Util' => '1.19',
+ 'Locale::Constants' => '2.07',
+ 'Locale::Country' => '2.07',
+ 'Locale::Currency' => '2.07',
+ 'Locale::Language' => '2.07',
+ 'Locale::Maketext' => '1.13',
+ 'Locale::Maketext::Guts'=> '1.13',
+ 'Locale::Maketext::GutsLoader'=> '1.13',
+ 'Locale::Script' => '2.07',
+ 'MIME::Base64' => '3.07',
+ 'MIME::QuotedPrint' => '3.07',
+ 'Math::BigFloat' => '1.60',
+ 'Math::BigFloat::Trace' => '0.01',
+ 'Math::BigInt' => '1.89',
+ 'Math::BigInt::Calc' => '0.52',
+ 'Math::BigInt::CalcEmu' => '0.05',
+ 'Math::BigInt::Trace' => '0.01',
+ 'Math::BigRat' => '0.22',
+ 'Math::Complex' => '1.54',
+ 'Math::Trig' => '1.18',
+ 'Memoize' => '1.01',
+ 'Memoize::AnyDBM_File' => '0.65',
+ 'Memoize::Expire' => '1.00',
+ 'Memoize::ExpireFile' => '1.01',
+ 'Memoize::ExpireTest' => '0.65',
+ 'Memoize::NDBM_File' => '0.65',
+ 'Memoize::SDBM_File' => '0.65',
+ 'Memoize::Storable' => '0.65',
+ 'Module::CoreList' => '2.17',
+ 'Module::Pluggable' => '3.8',
+ 'Module::Pluggable::Object'=> '3.6',
+ 'Module::Pluggable::lib::Devel::InnerPackage'=> '0.3',
+ 'NDBM_File' => '1.07',
+ 'NEXT' => '0.61',
+ 'Net::Cmd' => '2.29',
+ 'Net::Config' => '1.11',
+ 'Net::Domain' => '2.20',
+ 'Net::FTP' => '2.77',
+ 'Net::FTP::A' => '1.18',
+ 'Net::FTP::E' => '0.01',
+ 'Net::FTP::I' => '1.12',
+ 'Net::FTP::L' => '0.01',
+ 'Net::FTP::dataconn' => '0.11',
+ 'Net::NNTP' => '2.24',
+ 'Net::Netrc' => '2.12',
+ 'Net::POP3' => '2.29',
+ 'Net::Ping' => '2.35',
+ 'Net::SMTP' => '2.31',
+ 'Net::Time' => '2.10',
+ 'Net::hostent' => '1.01',
+ 'Net::netent' => '1.00',
+ 'Net::protoent' => '1.00',
+ 'Net::servent' => '1.01',
+ 'O' => '1.01',
+ 'ODBM_File' => '1.07',
+ 'Opcode' => '1.0601',
+ 'POSIX' => '1.15',
+ 'PerlIO' => '1.05',
+ 'PerlIO::encoding' => '0.11',
+ 'PerlIO::scalar' => '0.06',
+ 'PerlIO::via' => '0.05',
+ 'PerlIO::via::QuotedPrint'=> '0.06',
+ 'Pod::Checker' => '1.43',
+ 'Pod::Find' => '1.34',
+ 'Pod::Functions' => '1.03',
+ 'Pod::Html' => '1.09',
+ 'Pod::InputObjects' => '1.3',
+ 'Pod::LaTeX' => '0.58',
+ 'Pod::Man' => '1.37',
+ 'Pod::ParseLink' => '1.06',
+ 'Pod::ParseUtils' => '1.35',
+ 'Pod::Parser' => '1.35',
+ 'Pod::Perldoc' => '3.14',
+ 'Pod::Perldoc::BaseTo' => undef,
+ 'Pod::Perldoc::GetOptsOO'=> undef,
+ 'Pod::Perldoc::ToChecker'=> undef,
+ 'Pod::Perldoc::ToMan' => undef,
+ 'Pod::Perldoc::ToNroff' => undef,
+ 'Pod::Perldoc::ToPod' => undef,
+ 'Pod::Perldoc::ToRtf' => undef,
+ 'Pod::Perldoc::ToText' => undef,
+ 'Pod::Perldoc::ToTk' => undef,
+ 'Pod::Perldoc::ToXml' => undef,
+ 'Pod::PlainText' => '2.02',
+ 'Pod::Plainer' => '0.01',
+ 'Pod::Select' => '1.35',
+ 'Pod::Text' => '2.21',
+ 'Pod::Text::Color' => '1.04',
+ 'Pod::Text::Overstrike' => '1.1',
+ 'Pod::Text::Termcap' => '1.11',
+ 'Pod::Usage' => '1.35',
+ 'SDBM_File' => '1.06',
+ 'Safe' => '2.16',
+ 'Scalar::Util' => '1.19',
+ 'Search::Dict' => '1.02',
+ 'SelectSaver' => '1.01',
+ 'SelfLoader' => '1.17',
+ 'Shell' => '0.72',
+ 'Socket' => '1.81',
+ 'Stdio' => '2.4',
+ 'Storable' => '2.19',
+ 'Switch' => '2.13',
+ 'Symbol' => '1.06',
+ 'Sys::Hostname' => '1.11',
+ 'Sys::Syslog' => '0.27',
+ 'Sys::Syslog::win32::Win32'=> undef,
+ 'Term::ANSIColor' => '1.12',
+ 'Term::Cap' => '1.12',
+ 'Term::Complete' => '1.402',
+ 'Term::ReadLine' => '1.03',
+ 'Test' => '1.25',
+ 'Test::Builder' => '0.80',
+ 'Test::Builder::Module' => '0.80',
+ 'Test::Builder::Tester' => '1.13',
+ 'Test::Builder::Tester::Color'=> undef,
+ 'Test::Harness' => '2.64',
+ 'Test::Harness::Assert' => '0.02',
+ 'Test::Harness::Iterator'=> '0.02',
+ 'Test::Harness::Point' => '0.01',
+ 'Test::Harness::Results'=> '0.01_01',
+ 'Test::Harness::Straps' => '0.26_01',
+ 'Test::Harness::Util' => '0.01',
+ 'Test::More' => '0.80',
+ 'Test::Simple' => '0.80',
+ 'Text::Abbrev' => '1.01',
+ 'Text::Balanced' => '1.98',
+ 'Text::ParseWords' => '3.27',
+ 'Text::Soundex' => '3.03',
+ 'Text::Tabs' => '2007.1117',
+ 'Text::Wrap' => '2006.1117',
+ 'Thread' => '2.01',
+ 'Thread::Queue' => '2.11',
+ 'Thread::Semaphore' => '2.09',
+ 'Thread::Signal' => '1.00',
+ 'Thread::Specific' => '1.00',
+ 'Tie::Array' => '1.03',
+ 'Tie::File' => '0.97',
+ 'Tie::Handle' => '4.2',
+ 'Tie::Hash' => '1.03',
+ 'Tie::Memoize' => '1.1',
+ 'Tie::RefHash' => '1.38',
+ 'Tie::Scalar' => '1.01',
+ 'Tie::StdHandle' => '4.2',
+ 'Tie::SubstrHash' => '1.00',
+ 'Time::HiRes' => '1.9715',
+ 'Time::Local' => '1.1901',
+ 'Time::gmtime' => '1.03',
+ 'Time::localtime' => '1.02',
+ 'Time::tm' => '1.00',
+ 'UNIVERSAL' => '1.01',
+ 'Unicode' => '5.1.0',
+ 'Unicode::Collate' => '0.52',
+ 'Unicode::Normalize' => '1.02',
+ 'Unicode::UCD' => '0.25',
+ 'User::grent' => '1.01',
+ 'User::pwent' => '1.00',
+ 'Win32' => '0.38',
+ 'Win32API::File' => '0.1001_01',
+ 'Win32API::File::ExtUtils::Myconst2perl'=> '1',
+ 'Win32CORE' => '0.02',
+ 'XS::APItest' => '0.15',
+ 'XS::Typemap' => '0.03',
+ 'XSLoader' => '0.10',
+ 'XSSymSet' => '1.1',
+ 'attributes' => '0.09',
+ 'attrs' => '1.02',
+ 'autouse' => '1.06',
+ 'base' => '2.13',
+ 'bigint' => '0.23',
+ 'bignum' => '0.23',
+ 'bigrat' => '0.23',
+ 'blib' => '1.04',
+ 'bytes' => '1.02',
+ 'charnames' => '1.06',
+ 'constant' => '1.17',
+ 'diagnostics' => '1.16',
+ 'encoding' => '2.6_01',
+ 'fields' => '2.12',
+ 'filetest' => '1.02',
+ 'if' => '0.05',
+ 'integer' => '1.00',
+ 'less' => '0.01',
+ 'lib' => '0.61',
+ 'locale' => '1.00',
+ 'open' => '1.06',
+ 'ops' => '1.02',
+ 'overload' => '1.06',
+ 're' => '0.0601',
+ 'sigtrap' => '1.04',
+ 'sort' => '1.02',
+ 'strict' => '1.03',
+ 'subs' => '1.00',
+ 'threads' => '1.71',
+ 'threads::shared' => '1.27',
+ 'utf8' => '1.07',
+ 'vars' => '1.01',
+ 'vmsish' => '1.02',
+ 'warnings' => '1.05_01',
+ 'warnings::register' => '1.01',
+ },
);
+# Create aliases with trailing zeros for $] use
+
+$released{'5.000'} = $released{5};
+$released{'5.010000'} = $released{5.01};
+
+$patchlevel{'5.000'} = $patchlevel{5};
+$patchlevel{'5.010000'} = $patchlevel{5.01};
+
+$version{'5.000'} = $version{5};
+$version{'5.010000'} = $version{5.01};
+
1;
__END__

View File

@ -1,178 +0,0 @@
Module-Load-Conditional-0.30
diff -ur perl-5.10.0.orig/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t perl-5.10.0/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t
--- perl-5.10.0.orig/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Module/Load/Conditional/t/01_Module_Load_Conditional.t 2009-02-10 11:41:18.000000000 +0100
@@ -20,8 +20,8 @@
use constant ON_VMS => $^O eq 'VMS';
-use lib "$FindBin::Bin/../lib";
-use lib "$FindBin::Bin/to_load";
+use lib File::Spec->catdir($FindBin::Bin, qw[.. lib] );
+use lib File::Spec->catdir($FindBin::Bin, q[to_load] );
use_ok( 'Module::Load::Conditional' );
@@ -46,6 +46,23 @@
ok( $rv->{uptodate}, q[Verify self] );
is( $rv->{version}, $Module::Load::Conditional::VERSION,
q[ Found proper version] );
+ ok( $rv->{dir}, q[ Found directory information] );
+
+ { my $dir = File::Spec->canonpath( $rv->{dir} );
+
+ ### special rules apply on VMS, as always...
+ if (ON_VMS) {
+ ### Need path syntax for VMS compares.
+ $dir = VMS::Filespec::pathify($dir);
+ ### Remove the trailing VMS specific directory delimiter
+ $dir =~ s/\]//;
+ }
+
+ ### quote for Win32 paths, use | to avoid slash confusion
+ my $dir_re = qr|^\Q$dir\E|i;
+ like( File::Spec->canonpath( $rv->{file} ), $dir_re,
+ q[ Dir subset of file path] );
+ }
### break up the specification
my @rv_path = do {
@@ -64,11 +81,17 @@
### and return it
@path;
};
-
- is( $INC{'Module/Load/Conditional.pm'},
+ my $inc_path = $INC{'Module/Load/Conditional.pm'};
+ if ( $^O eq 'MSWin32' ) {
+ $inc_path = File::Spec->canonpath( $inc_path );
+ $inc_path =~ s{\\}{/}g; # to meet with unix path
+ }
+ is( $inc_path,
File::Spec::Unix->catfile(@rv_path),
q[ Found proper file]
);
+
+
}
diff -ur perl-5.10.0.orig/lib/Module/Load/Conditional.pm perl-5.10.0/lib/Module/Load/Conditional.pm
--- perl-5.10.0.orig/lib/Module/Load/Conditional.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/Module/Load/Conditional.pm 2009-02-10 11:40:22.000000000 +0100
@@ -9,7 +9,7 @@
use Carp ();
use File::Spec ();
use FileHandle ();
-use version qw[qv];
+use version;
use constant ON_VMS => $^O eq 'VMS';
@@ -18,7 +18,7 @@
$FIND_VERSION $ERROR $CHECK_INC_HASH];
use Exporter;
@ISA = qw[Exporter];
- $VERSION = '0.22';
+ $VERSION = '0.30';
$VERBOSE = 0;
$FIND_VERSION = 1;
$CHECK_INC_HASH = 0;
@@ -116,6 +116,11 @@
Full path to the file that contains the module
+=item dir
+
+Directory, or more exact the C<@INC> entry, where the module was
+loaded from.
+
=item version
The version number of the installed module - this will be C<undef> if
@@ -226,6 +231,9 @@
}
}
+ ### store the directory we found the file in
+ $href->{dir} = $dir;
+
### files need to be in unix format under vms,
### or they might be loaded twice
$href->{file} = ON_VMS
@@ -236,18 +244,20 @@
if( $FIND_VERSION ) {
my $in_pod = 0;
- while (local $_ = <$fh> ) {
+ while ( my $line = <$fh> ) {
### stolen from EU::MM_Unix->parse_version to address
### #24062: "Problem with CPANPLUS 0.076 misidentifying
### versions after installing Text::NSP 1.03" where a
### VERSION mentioned in the POD was found before
### the real $VERSION declaration.
- $in_pod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $in_pod;
+ $in_pod = $line =~ /^=(?!cut)/ ? 1 :
+ $line =~ /^=cut/ ? 0 :
+ $in_pod;
next if $in_pod;
### try to find a version declaration in this string.
- my $ver = __PACKAGE__->_parse_version( $_ );
+ my $ver = __PACKAGE__->_parse_version( $line );
if( defined $ver ) {
$href->{version} = $ver;
@@ -280,8 +290,14 @@
### use qv(), as it will deal with developer release number
### ie ones containing _ as well. This addresses bug report
### #29348: Version compare logic doesn't handle alphas?
+ ###
+ ### Update from JPeacock: apparently qv() and version->new
+ ### are different things, and we *must* use version->new
+ ### here, or things like #30056 might start happening
$href->{uptodate} =
- qv( $args->{version} ) <= qv( $href->{version} ) ? 1 : 0;
+ version->new( $args->{version} ) <= version->new( $href->{version} )
+ ? 1
+ : 0;
}
return $href;
@@ -301,7 +317,8 @@
### regex breaks under -T, we must modifiy it so
### it captures the entire expression, and eval /that/
### rather than $_, which is insecure.
-
+ my $taint_safe_str = do { $str =~ /(^.*$)/sm; $1 };
+
if( $str =~ /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) {
print "Evaluating: $str\n" if $verbose;
@@ -321,7 +338,7 @@
local $1$2;
\$$2=undef; do {
- $str
+ $taint_safe_str
}; \$$2
};
@@ -426,9 +443,14 @@
### use qv(), as it will deal with developer release number
### ie ones containing _ as well. This addresses bug report
### #29348: Version compare logic doesn't handle alphas?
+ ###
+ ### Update from JPeacock: apparently qv() and version->new
+ ### are different things, and we *must* use version->new
+ ### here, or things like #30056 might start happening
if ( !$args->{nocache}
&& defined $CACHE->{$mod}->{usable}
- && (qv($CACHE->{$mod}->{version}||0) >= qv($href->{$mod}))
+ && (version->new( $CACHE->{$mod}->{version}||0 )
+ >= version->new( $href->{$mod} ) )
) {
$error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
last BLOCK;

View File

@ -1,964 +0,0 @@
This patch is derived from the perl-5.10.1 tarball as released on the CPAN.
diff -urN perl-5.10.0.orig/lib/Devel/InnerPackage.pm perl-5.10.0/lib/Devel/InnerPackage.pm
--- perl-5.10.0.orig/lib/Devel/InnerPackage.pm 2007-12-18 02:47:07.000000000 -0800
+++ perl-5.10.0/lib/Devel/InnerPackage.pm 2009-08-31 19:47:24.444773931 -0700
@@ -17,7 +17,7 @@
=head1 SYNOPSIS
use Foo::Bar;
- use Devel::innerPackage qw(list_packages);
+ use Devel::InnerPackage qw(list_packages);
my @inner_packages = list_packages('Foo::Bar');
@@ -75,7 +75,7 @@
!__PACKAGE__->_loaded($pack.$cand); # or @children;
push @packs, @children;
}
- return grep {$_ !~ /::::ISA::CACHE/} @packs;
+ return grep {$_ !~ /::(::ISA::CACHE|SUPER)/} @packs;
}
### XXX this is an inlining of the Class-Inspector->loaded()
diff -urN perl-5.10.0.orig/lib/Module/Pluggable/Object.pm perl-5.10.0/lib/Module/Pluggable/Object.pm
--- perl-5.10.0.orig/lib/Module/Pluggable/Object.pm 2007-12-18 02:47:07.000000000 -0800
+++ perl-5.10.0/lib/Module/Pluggable/Object.pm 2009-08-31 19:47:24.446771196 -0700
@@ -6,10 +6,9 @@
use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
use Carp qw(croak carp);
use Devel::InnerPackage;
-use Data::Dumper;
use vars qw($VERSION);
-$VERSION = '3.6';
+$VERSION = '3.9';
sub new {
@@ -20,6 +19,10 @@
}
+### Eugggh, this code smells
+### This is what happens when you keep adding patches
+### *sigh*
+
sub plugins {
my $self = shift;
@@ -30,14 +33,14 @@
my $filename = $self->{'filename'};
my $pkg = $self->{'package'};
+ # Get the exception params instantiated
+ $self->_setup_exceptions;
+
# automatically turn a scalar search path or namespace into a arrayref
for (qw(search_path search_dirs)) {
$self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
}
-
-
-
# default search path is '<Module>::<Name>::Plugin'
$self->{'search_path'} = ["${pkg}::Plugin"] unless $self->{'search_path'};
@@ -46,13 +49,14 @@
# check to see if we're running under test
- my @SEARCHDIR = exists $INC{"blib.pm"} && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;
+ my @SEARCHDIR = exists $INC{"blib.pm"} && defined $filename && $filename =~ m!(^|/)blib/! ? grep {/blib/} @INC : @INC;
# add any search_dir params
unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
my @plugins = $self->search_directories(@SEARCHDIR);
+ push(@plugins, $self->handle_innerpackages($_)) for @{$self->{'search_path'}};
# push @plugins, map { print STDERR "$_\n"; $_->require } list_packages($_) for (@{$self->{'search_path'}});
@@ -60,43 +64,12 @@
return () unless @plugins;
- # exceptions
- my %only;
- my %except;
- my $only;
- my $except;
-
- if (defined $self->{'only'}) {
- if (ref($self->{'only'}) eq 'ARRAY') {
- %only = map { $_ => 1 } @{$self->{'only'}};
- } elsif (ref($self->{'only'}) eq 'Regexp') {
- $only = $self->{'only'}
- } elsif (ref($self->{'only'}) eq '') {
- $only{$self->{'only'}} = 1;
- }
- }
-
-
- if (defined $self->{'except'}) {
- if (ref($self->{'except'}) eq 'ARRAY') {
- %except = map { $_ => 1 } @{$self->{'except'}};
- } elsif (ref($self->{'except'}) eq 'Regexp') {
- $except = $self->{'except'}
- } elsif (ref($self->{'except'}) eq '') {
- $except{$self->{'except'}} = 1;
- }
- }
-
# remove duplicates
# probably not necessary but hey ho
my %plugins;
for(@plugins) {
- next if (keys %only && !$only{$_} );
- next unless (!defined $only || m!$only! );
-
- next if (keys %except && $except{$_} );
- next if (defined $except && m!$except! );
+ next unless $self->_is_legit($_);
$plugins{$_} = 1;
}
@@ -112,6 +85,58 @@
}
+sub _setup_exceptions {
+ my $self = shift;
+
+ my %only;
+ my %except;
+ my $only;
+ my $except;
+
+ if (defined $self->{'only'}) {
+ if (ref($self->{'only'}) eq 'ARRAY') {
+ %only = map { $_ => 1 } @{$self->{'only'}};
+ } elsif (ref($self->{'only'}) eq 'Regexp') {
+ $only = $self->{'only'}
+ } elsif (ref($self->{'only'}) eq '') {
+ $only{$self->{'only'}} = 1;
+ }
+ }
+
+
+ if (defined $self->{'except'}) {
+ if (ref($self->{'except'}) eq 'ARRAY') {
+ %except = map { $_ => 1 } @{$self->{'except'}};
+ } elsif (ref($self->{'except'}) eq 'Regexp') {
+ $except = $self->{'except'}
+ } elsif (ref($self->{'except'}) eq '') {
+ $except{$self->{'except'}} = 1;
+ }
+ }
+ $self->{_exceptions}->{only_hash} = \%only;
+ $self->{_exceptions}->{only} = $only;
+ $self->{_exceptions}->{except_hash} = \%except;
+ $self->{_exceptions}->{except} = $except;
+
+}
+
+sub _is_legit {
+ my $self = shift;
+ my $plugin = shift;
+ my %only = %{$self->{_exceptions}->{only_hash}||{}};
+ my %except = %{$self->{_exceptions}->{except_hash}||{}};
+ my $only = $self->{_exceptions}->{only};
+ my $except = $self->{_exceptions}->{except};
+
+ return 0 if (keys %only && !$only{$plugin} );
+ return 0 unless (!defined $only || $plugin =~ m!$only! );
+
+ return 0 if (keys %except && $except{$plugin} );
+ return 0 if (defined $except && $plugin =~ m!$except! );
+
+ return 1;
+}
+
sub search_directories {
my $self = shift;
my @SEARCHDIR = @_;
@@ -121,7 +146,6 @@
foreach my $dir (@SEARCHDIR) {
push @plugins, $self->search_paths($dir);
}
-
return @plugins;
}
@@ -151,6 +175,8 @@
# parse the file to get the name
my ($name, $directory, $suffix) = fileparse($file, $file_regex);
+ next if (!$self->{include_editor_junk} && $self->_is_editor_junk($name));
+
$directory = abs2rel($directory, $sp);
# If we have a mixed-case package name, assume case has been preserved
@@ -203,17 +229,34 @@
# now add stuff that may have been in package
# NOTE we should probably use all the stuff we've been given already
# but then we can't unload it :(
- push @plugins, $self->handle_innerpackages($searchpath) unless (exists $self->{inner} && !$self->{inner});
+ push @plugins, $self->handle_innerpackages($searchpath);
} # foreach $searchpath
return @plugins;
}
+sub _is_editor_junk {
+ my $self = shift;
+ my $name = shift;
+
+ # Emacs (and other Unix-y editors) leave temp files ending in a
+ # tilde as a backup.
+ return 1 if $name =~ /~$/;
+ # Emacs makes these files while a buffer is edited but not yet
+ # saved.
+ return 1 if $name =~ /^\.#/;
+ # Vim can leave these files behind if it crashes.
+ return 1 if $name =~ /\.sw[po]$/;
+
+ return 0;
+}
+
sub handle_finding_plugin {
my $self = shift;
my $plugin = shift;
return unless (defined $self->{'instantiate'} || $self->{'require'});
+ return unless $self->_is_legit($plugin);
$self->_require($plugin);
}
@@ -245,10 +288,11 @@
sub handle_innerpackages {
my $self = shift;
+ return () if (exists $self->{inner} && !$self->{inner});
+
my $path = shift;
my @plugins;
-
foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
my $err = $self->handle_finding_plugin($plugin);
#next if $err;
@@ -299,6 +343,14 @@
Optionally it instantiates those classes for you.
+This object is wrapped by C<Module::Pluggable>. If you want to do something
+odd or add non-general special features you're probably best to wrap this
+and produce your own subclass.
+
+=head1 OPTIONS
+
+See the C<Module::Pluggable> docs.
+
=head1 AUTHOR
Simon Wistow <simon@thegestalt.org>
diff -urN perl-5.10.0.orig/lib/Module/Pluggable.pm perl-5.10.0/lib/Module/Pluggable.pm
--- perl-5.10.0.orig/lib/Module/Pluggable.pm 2007-12-18 02:47:07.000000000 -0800
+++ perl-5.10.0/lib/Module/Pluggable.pm 2009-08-31 19:47:24.448771465 -0700
@@ -9,7 +9,7 @@
# Peter Gibbons: I wouldn't say I've been missing it, Bob!
-$VERSION = '3.6';
+$VERSION = '3.9';
sub import {
my $class = shift;
@@ -60,8 +60,9 @@
no strict 'refs';
- no warnings 'redefine';
- *{"$package\::$sub"} = $subroutine;
+ no warnings qw(redefine prototype);
+
+ *{"$package\::$sub"} = $subroutine;
*{"$package\::search_path"} = $searchsub;
*{"$package\::only"} = $onlysub;
*{"$package\::except"} = $exceptsub;
@@ -297,6 +298,14 @@
file_regex => qr/\.plugin$/
+=head2 include_editor_junk
+
+By default C<Module::Pluggable> ignores files that look like they were
+left behind by editors. Currently this means files ending in F<~> (~),
+the extensions F<.swp> or F<.swo>, or files beginning with F<.#>.
+
+Setting C<include_editor_junk> changes C<Module::Pluggable> so it does
+not ignore any files it finds.
=head1 METHODs
diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
--- perl-5.10.0.orig/MANIFEST 2007-12-18 02:47:07.000000000 -0800
+++ perl-5.10.0/MANIFEST 2009-08-31 19:47:24.452770885 -0700
@@ -3612,11 +3612,14 @@
t/Module_Pluggable/09require.t Module::Pluggable tests
t/Module_Pluggable/10innerpack_inner.t Module::Pluggable tests
t/Module_Pluggable/10innerpack_noinner.t Module::Pluggable tests
+t/Module_Pluggable/10innerpack_onefile.t Module::Pluggable tests
t/Module_Pluggable/10innerpack_override.t Module::Pluggable tests
+t/Module_Pluggable/10innerpack_super.t Module::Pluggable tests
t/Module_Pluggable/10innerpack.t Module::Pluggable tests
t/Module_Pluggable/11usetwice.t Module::Pluggable tests
t/Module_Pluggable/12onlyarray.t Module::Pluggable tests
t/Module_Pluggable/12onlyregex.t Module::Pluggable tests
+t/Module_Pluggable/12onlyrequire.t Module::Pluggable tests
t/Module_Pluggable/12only.t Module::Pluggable tests
t/Module_Pluggable/13exceptarray.t Module::Pluggable tests
t/Module_Pluggable/13exceptregex.t Module::Pluggable tests
@@ -3628,8 +3631,15 @@
t/Module_Pluggable/18skipped_package.t Module::Pluggable tests
t/Module_Pluggable/19can_ok_clobber.t Module::Pluggable tests
t/Module_Pluggable/20dodgy_files.t Module::Pluggable tests
+t/Module_Pluggable/21editor_junk.t Module::Pluggable tests
t/Module_Pluggable/acme/Acme/MyTest/Plugin/Foo.pm Module::Pluggable tests
t/Module_Pluggable/lib/Acme/MyTest/Plugin/Foo.pm Module::Pluggable tests
+t/Module_Pluggable/lib/Acme/Foo-Bar.pm Module::Pluggable tests
+t/Module_Pluggable/lib/EditorJunk/Plugin/Foo.pm Module::Pluggable tests
+t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swo Module::Pluggable tests
+t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swp Module::Pluggable tests
+t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm~ Module::Pluggable tests
+t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm Module::Pluggable tests
t/Module_Pluggable/lib/ExtTest/Plugin/Bar.plugin Module::Pluggable tests
t/Module_Pluggable/lib/ExtTest/Plugin/Foo.plugin Module::Pluggable tests
t/Module_Pluggable/lib/ExtTest/Plugin/Quux/Foo.plugin Module::Pluggable tests
@@ -3646,6 +3656,7 @@
t/Module_Pluggable/lib/OddTest/Plugin/-Dodgy.pm Module::Pluggable tests
t/Module_Pluggable/lib/OddTest/Plugin/Foo.pm Module::Pluggable tests
t/Module_Pluggable/lib/TA/C/A/I.pm Module::Pluggable tests
+t/Module_Pluggable/lib/Zot/.Zork.pm Module::Pluggable tests
t/mro/basic_01_c3.t mro tests
t/mro/basic_01_dfs.t mro tests
t/mro/basic_02_c3.t mro tests
diff -urN perl-5.10.0.orig/t/Module_Pluggable/02alsoworks.t perl-5.10.0/t/Module_Pluggable/02alsoworks.t
--- perl-5.10.0.orig/t/Module_Pluggable/02alsoworks.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/02alsoworks.t 2009-08-31 19:47:24.454770805 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 5;
my $foo;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/02works.t perl-5.10.0/t/Module_Pluggable/02works.t
--- perl-5.10.0.orig/t/Module_Pluggable/02works.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/02works.t 2009-08-31 19:47:24.455771358 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 5;
my $foo;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/03diffname.t perl-5.10.0/t/Module_Pluggable/03diffname.t
--- perl-5.10.0.orig/t/Module_Pluggable/03diffname.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/03diffname.t 2009-08-31 19:47:24.456771493 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
my $foo;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/04acmedir_single.t perl-5.10.0/t/Module_Pluggable/04acmedir_single.t
--- perl-5.10.0.orig/t/Module_Pluggable/04acmedir_single.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/04acmedir_single.t 2009-08-31 19:47:24.456771493 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/04acmedir.t perl-5.10.0/t/Module_Pluggable/04acmedir.t
--- perl-5.10.0.orig/t/Module_Pluggable/04acmedir.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/04acmedir.t 2009-08-31 19:47:24.457771627 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/04acmepath_single.t perl-5.10.0/t/Module_Pluggable/04acmepath_single.t
--- perl-5.10.0.orig/t/Module_Pluggable/04acmepath_single.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/04acmepath_single.t 2009-08-31 19:47:24.458773508 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/04acmepath.t perl-5.10.0/t/Module_Pluggable/04acmepath.t
--- perl-5.10.0.orig/t/Module_Pluggable/04acmepath.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/04acmepath.t 2009-08-31 19:47:24.459772105 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/05postpath.t perl-5.10.0/t/Module_Pluggable/05postpath.t
--- perl-5.10.0.orig/t/Module_Pluggable/05postpath.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/05postpath.t 2009-08-31 19:47:24.460771332 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/06multipath.t perl-5.10.0/t/Module_Pluggable/06multipath.t
--- perl-5.10.0.orig/t/Module_Pluggable/06multipath.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/06multipath.t 2009-08-31 19:47:24.461771676 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/07instantiate.t perl-5.10.0/t/Module_Pluggable/07instantiate.t
--- perl-5.10.0.orig/t/Module_Pluggable/07instantiate.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/07instantiate.t 2009-08-31 19:47:24.462772090 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 6;
my $foo;
@@ -26,7 +26,7 @@
use File::Spec::Functions qw(catdir);
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Module::Pluggable (search_path => ["MyTest::Extend::Plugin"], sub_name => 'booga', instantiate => 'new');
use Module::Pluggable (search_path => ["MyTest::Extend::Plugin"], sub_name => 'wooga', instantiate => 'nosomuchmethod');
diff -urN perl-5.10.0.orig/t/Module_Pluggable/08nothing.t perl-5.10.0/t/Module_Pluggable/08nothing.t
--- perl-5.10.0.orig/t/Module_Pluggable/08nothing.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/08nothing.t 2009-08-31 19:47:24.463771316 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 2;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/09require.t perl-5.10.0/t/Module_Pluggable/09require.t
--- perl-5.10.0.orig/t/Module_Pluggable/09require.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/09require.t 2009-08-31 19:47:24.464771800 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 2;
my $t = MyTest->new();
diff -urN perl-5.10.0.orig/t/Module_Pluggable/10innerpack_inner.t perl-5.10.0/t/Module_Pluggable/10innerpack_inner.t
--- perl-5.10.0.orig/t/Module_Pluggable/10innerpack_inner.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/10innerpack_inner.t 2009-08-31 19:47:24.465771515 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/10innerpack_noinner.t perl-5.10.0/t/Module_Pluggable/10innerpack_noinner.t
--- perl-5.10.0.orig/t/Module_Pluggable/10innerpack_noinner.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/10innerpack_noinner.t 2009-08-31 19:47:24.479772629 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/10innerpack_onefile.t perl-5.10.0/t/Module_Pluggable/10innerpack_onefile.t
--- perl-5.10.0.orig/t/Module_Pluggable/10innerpack_onefile.t 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/10innerpack_onefile.t 2009-08-31 19:47:24.480772134 -0700
@@ -0,0 +1,27 @@
+#!perl -wT
+
+use strict;
+use Test::More tests => 2;
+use Data::Dumper;
+
+my $mc = MyClass->new();
+my $mc2 = MyClass2->new();
+
+
+is_deeply([$mc->plugins], [qw(MyClass::Plugin::MyPlugin)], "Got inner plugin");
+is_deeply([$mc2->plugins], [], "Didn't get plugin");
+
+package MyClass::Plugin::MyPlugin;
+sub pretty { print "I am pretty" };
+
+package MyClass;
+use Module::Pluggable inner => 1;
+
+sub new { return bless {}, $_[0] }
+
+package MyClass2;
+use Module::Pluggable search_path => "MyClass::Plugin", inner => 0;
+
+sub new { return bless {}, $_[0] }
+1;
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/10innerpack_override.t perl-5.10.0/t/Module_Pluggable/10innerpack_override.t
--- perl-5.10.0.orig/t/Module_Pluggable/10innerpack_override.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/10innerpack_override.t 2009-08-31 19:47:24.481771501 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/10innerpack_super.t perl-5.10.0/t/Module_Pluggable/10innerpack_super.t
--- perl-5.10.0.orig/t/Module_Pluggable/10innerpack_super.t 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/10innerpack_super.t 2009-08-31 19:47:24.482771565 -0700
@@ -0,0 +1,29 @@
+#!perl -wT
+
+use Test::More tests => 3;
+use strict;
+use_ok('Devel::InnerPackage');
+Bar->whee;
+is_deeply([Devel::InnerPackage::list_packages("Bar")],[], "Don't pick up ::SUPER pseudo stash");
+is_deeply([Devel::InnerPackage::list_packages("Foo")],['Foo::Bar'], "Still pick up other inner package");
+
+package Foo;
+
+sub whee {
+ 1;
+}
+
+package Foo::Bar;
+
+sub whee {}
+
+package Bar;
+use base 'Foo';
+
+sub whee {
+ shift->SUPER::whee;
+ 2;
+}
+
+
+1;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/10innerpack.t perl-5.10.0/t/Module_Pluggable/10innerpack.t
--- perl-5.10.0.orig/t/Module_Pluggable/10innerpack.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/10innerpack.t 2009-08-31 19:47:24.483771909 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 4;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/11usetwice.t perl-5.10.0/t/Module_Pluggable/11usetwice.t
--- perl-5.10.0.orig/t/Module_Pluggable/11usetwice.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/11usetwice.t 2009-08-31 19:47:24.484771624 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 3;
my $foo;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/12onlyarray.t perl-5.10.0/t/Module_Pluggable/12onlyarray.t
--- perl-5.10.0.orig/t/Module_Pluggable/12onlyarray.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/12onlyarray.t 2009-08-31 19:47:24.485772038 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 10;
{
diff -urN perl-5.10.0.orig/t/Module_Pluggable/12onlyregex.t perl-5.10.0/t/Module_Pluggable/12onlyregex.t
--- perl-5.10.0.orig/t/Module_Pluggable/12onlyregex.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/12onlyregex.t 2009-08-31 19:47:24.485772038 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 10;
{
diff -urN perl-5.10.0.orig/t/Module_Pluggable/12onlyrequire.t perl-5.10.0/t/Module_Pluggable/12onlyrequire.t
--- perl-5.10.0.orig/t/Module_Pluggable/12onlyrequire.t 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/12onlyrequire.t 2009-08-31 19:47:24.505021273 -0700
@@ -0,0 +1,21 @@
+#!perl -w
+use strict;
+use FindBin;
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
+use Test::More tests => 2;
+
+my @packages = eval { Zot->_dist_types };
+is($@, '', "No warnings");
+is(scalar(@packages), 0, "Correctly only got 1 package");
+
+
+package Zot;
+use strict;
+use Module::Pluggable (
+ sub_name => '_dist_types',
+ search_path => __PACKAGE__,
+ only => qr/Zot::\w+$/,
+ require => 1,
+ );
+
+1;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/12only.t perl-5.10.0/t/Module_Pluggable/12only.t
--- perl-5.10.0.orig/t/Module_Pluggable/12only.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/12only.t 2009-08-31 19:47:24.506022385 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 10;
{
diff -urN perl-5.10.0.orig/t/Module_Pluggable/13exceptarray.t perl-5.10.0/t/Module_Pluggable/13exceptarray.t
--- perl-5.10.0.orig/t/Module_Pluggable/13exceptarray.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/13exceptarray.t 2009-08-31 19:47:24.507021263 -0700
@@ -1,8 +1,8 @@
-#!perl -w
+#!perl -wT
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 10;
{
diff -urN perl-5.10.0.orig/t/Module_Pluggable/13exceptregex.t perl-5.10.0/t/Module_Pluggable/13exceptregex.t
--- perl-5.10.0.orig/t/Module_Pluggable/13exceptregex.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/13exceptregex.t 2009-08-31 19:47:24.510021945 -0700
@@ -1,8 +1,8 @@
-#!perl -w
+#!perl -wT
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 10;
{
diff -urN perl-5.10.0.orig/t/Module_Pluggable/13except.t perl-5.10.0/t/Module_Pluggable/13except.t
--- perl-5.10.0.orig/t/Module_Pluggable/13except.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/13except.t 2009-08-31 19:47:24.511021381 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 10;
{
diff -urN perl-5.10.0.orig/t/Module_Pluggable/14package.t perl-5.10.0/t/Module_Pluggable/14package.t
--- perl-5.10.0.orig/t/Module_Pluggable/14package.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/14package.t 2009-08-31 19:47:24.842414378 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 5;
my $foo;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/15topicsafe.t perl-5.10.0/t/Module_Pluggable/15topicsafe.t
--- perl-5.10.0.orig/t/Module_Pluggable/15topicsafe.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/15topicsafe.t 2009-08-31 19:47:24.842774343 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More 'no_plan';
use Module::Pluggable search_path => 'Acme::MyTest';
diff -urN perl-5.10.0.orig/t/Module_Pluggable/16different_extension.t perl-5.10.0/t/Module_Pluggable/16different_extension.t
--- perl-5.10.0.orig/t/Module_Pluggable/16different_extension.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/16different_extension.t 2009-08-31 19:47:24.843800947 -0700
@@ -2,7 +2,7 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests => 5;
my $foo;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/17devel_inner_package.t perl-5.10.0/t/Module_Pluggable/17devel_inner_package.t
--- perl-5.10.0.orig/t/Module_Pluggable/17devel_inner_package.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/17devel_inner_package.t 2009-08-31 19:47:24.843800947 -0700
@@ -3,7 +3,7 @@
use Devel::InnerPackage qw(list_packages);
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
my @packages;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/18skipped_package.t perl-5.10.0/t/Module_Pluggable/18skipped_package.t
--- perl-5.10.0.orig/t/Module_Pluggable/18skipped_package.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/18skipped_package.t 2009-08-31 19:47:24.844780129 -0700
@@ -2,7 +2,7 @@
use Test::More tests => 1;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Devel::InnerPackage qw(list_packages);
use No::Middle;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/19can_ok_clobber.t perl-5.10.0/t/Module_Pluggable/19can_ok_clobber.t
--- perl-5.10.0.orig/t/Module_Pluggable/19can_ok_clobber.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/19can_ok_clobber.t 2009-08-31 19:47:24.844780129 -0700
@@ -3,7 +3,7 @@
use warnings;
use Data::Dumper;
use FindBin;
-use lib "$FindBin::Bin/lib";
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
use Test::More tests=>5;
diff -urN perl-5.10.0.orig/t/Module_Pluggable/20dodgy_files.t perl-5.10.0/t/Module_Pluggable/20dodgy_files.t
--- perl-5.10.0.orig/t/Module_Pluggable/20dodgy_files.t 2007-12-18 02:47:08.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/20dodgy_files.t 2009-08-31 19:47:24.845769158 -0700
@@ -1,7 +1,7 @@
#!perl -w
BEGIN {
- if ($^O eq 'VMS') {
+ if ($^O eq 'VMS' || $^O eq 'VOS') {
print "1..0 # Skip: can't handle misspelled plugin names\n";
exit;
}
@@ -9,8 +9,18 @@
use strict;
use FindBin;
-use lib "$FindBin::Bin/lib";
-use Test::More tests => 5;
+use Test::More;
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
+use File::Spec::Functions qw(catfile);
+
+
+my ($dodgy_file) = (catfile($FindBin::Bin, "lib", "OddTest", "Plugin", "-Dodgy.pm")=~/^(.*)$/);
+unless (-f $dodgy_file) {
+ plan skip_all => "Can't handle misspelled plugin names\n";
+} else {
+ plan tests => 5;
+}
+
my $foo;
ok($foo = OddTest->new());
diff -urN perl-5.10.0.orig/t/Module_Pluggable/21editor_junk.t perl-5.10.0/t/Module_Pluggable/21editor_junk.t
--- perl-5.10.0.orig/t/Module_Pluggable/21editor_junk.t 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/21editor_junk.t 2009-08-31 19:47:24.845769158 -0700
@@ -0,0 +1,53 @@
+#!perl -w
+
+use Test::More;
+use FindBin;
+use lib (($FindBin::Bin."/lib")=~/^(.*)$/);
+use Module::Pluggable::Object;
+use File::Spec::Functions qw(catfile);
+
+my ($dodgy_file) = (catfile($FindBin::Bin,"lib", "EditorJunk", "Plugin", "#Bar.pm#")=~/^(.*)$/);
+unless (-f $dodgy_file) {
+ plan skip_all => "Can't handle plugin names with octothorpes\n";
+} else {
+ plan tests => 4;
+}
+
+
+
+my $foo;
+ok($foo = EditorJunk->new());
+
+my @plugins;
+my @expected = qw(EditorJunk::Plugin::Bar EditorJunk::Plugin::Foo);
+ok(@plugins = sort $foo->plugins);
+
+is_deeply(\@plugins, \@expected, "is deeply");
+
+
+my $mpo = Module::Pluggable::Object->new(
+ package => 'EditorJunk',
+ filename => __FILE__,
+ include_editor_junk => 1,
+);
+
+@expected = ('EditorJunk::Plugin::.#Bar', 'EditorJunk::Plugin::Bar', 'EditorJunk::Plugin::Foo');
+@plugins = sort $mpo->plugins();
+is_deeply(\@plugins, \@expected, "is deeply");
+
+
+
+package EditorJunk;
+
+use strict;
+use Module::Pluggable;
+
+
+sub new {
+ my $class = shift;
+ return bless {}, $class;
+
+}
+1;
+
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/lib/Acme/Foo-Bar.pm perl-5.10.0/t/Module_Pluggable/lib/Acme/Foo-Bar.pm
--- perl-5.10.0.orig/t/Module_Pluggable/lib/Acme/Foo-Bar.pm 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/lib/Acme/Foo-Bar.pm 2009-08-31 19:47:24.845769158 -0700
@@ -0,0 +1,6 @@
+package Acme::FooBar;
+
+our $quux = "hello";
+
+1;
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm
--- perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm 2009-08-31 19:47:24.846769084 -0700
@@ -0,0 +1,9 @@
+package EditorJunk::Bar;
+
+
+use strict;
+
+
+1;
+
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm~ perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm~
--- perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm~ 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm~ 2009-08-31 19:47:24.851770803 -0700
@@ -0,0 +1,9 @@
+package EditorJunk::Bar;
+
+
+use strict;
+
+
+1;
+
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swo perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swo
--- perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swo 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swo 2009-08-31 19:47:24.852771985 -0700
@@ -0,0 +1,9 @@
+package EditorJunk::Bar;
+
+
+use strict;
+
+
+1;
+
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swp perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swp
--- perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swp 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Bar.pm.swp 2009-08-31 19:47:24.853771770 -0700
@@ -0,0 +1,9 @@
+package EditorJunk::Bar;
+
+
+use strict;
+
+
+1;
+
+
diff -urN perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Foo.pm perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Foo.pm
--- perl-5.10.0.orig/t/Module_Pluggable/lib/EditorJunk/Plugin/Foo.pm 1969-12-31 16:00:00.000000000 -0800
+++ perl-5.10.0/t/Module_Pluggable/lib/EditorJunk/Plugin/Foo.pm 2009-08-31 19:47:24.854771835 -0700
@@ -0,0 +1,9 @@
+package EditorJunk::Foo;
+
+
+use strict;
+
+
+1;
+
+

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -1,389 +0,0 @@
Storable-2.21
diff -urpN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
--- perl-5.10.0.orig/MANIFEST 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/MANIFEST 2009-10-01 13:18:44.000000000 +0200
@@ -1028,6 +1028,7 @@ ext/Socket/t/Socket.t See if Socket wor
ext/Storable/ChangeLog Storable extension
ext/Storable/hints/gnukfreebsd.pl Hint for Storable for named architecture
ext/Storable/hints/gnuknetbsd.pl Hint for Storable for named architecture
+ext/Storable/hints/hpux.pl Hint for Storable for named architecture
ext/Storable/hints/linux.pl Hint for Storable for named architecture
ext/Storable/Makefile.PL Storable extension
ext/Storable/MANIFEST Storable extension
diff -urpN perl-5.10.0.orig/ext/Storable/ChangeLog perl-5.10.0/ext/Storable/ChangeLog
--- perl-5.10.0.orig/ext/Storable/ChangeLog 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Storable/ChangeLog 2009-10-01 13:17:50.000000000 +0200
@@ -1,3 +1,18 @@
+Thu Aug 6 10:55:50 IST 2009 Abhijit Menon-Sen <ams@toroid.org>
+
+ Version 2.21
+
+ Includes hints/hpux.pl that was inadvertently left out of 2.20.
+
+Mon May 18 09:38:20 IST 2009 Abhijit Menon-Sen <ams@toroid.org>
+
+ Version 2.20
+
+ Fix bug handling blessed references to overloaded objects, plus
+ other miscellaneous fixes.
+
+ (Version 2.19 was released with 5.8.9.)
+
Thu Nov 22 13:24:18 IST 2007 Abhijit Menon-Sen <ams@toroid.org>
Version 2.18
diff -urpN perl-5.10.0.orig/ext/Storable/MANIFEST perl-5.10.0/ext/Storable/MANIFEST
--- perl-5.10.0.orig/ext/Storable/MANIFEST 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Storable/MANIFEST 2009-10-01 13:17:50.000000000 +0200
@@ -4,6 +4,7 @@ Makefile.PL Generic Makefile templa
Storable.pm The perl side of Storable
Storable.xs The C side of Storable
ChangeLog Changes since baseline
+hints/hpux.pl Hint file to drop to -O1 on HPUX
hints/linux.pl Hint file to drop gcc to -O2
hints/gnukfreebsd.pl Hint file to drop gcc to -O2
hints/gnuknetbsd.pl Hint file to drop gcc to -O2
diff -urpN perl-5.10.0.orig/ext/Storable/Makefile.PL perl-5.10.0/ext/Storable/Makefile.PL
--- perl-5.10.0.orig/ext/Storable/Makefile.PL 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Storable/Makefile.PL 2009-10-01 13:17:58.000000000 +0200
@@ -11,7 +11,6 @@ use Config;
WriteMakefile(
NAME => 'Storable',
DISTNAME => "Storable",
- MAN3PODS => {},
# We now ship this in t/
# PREREQ_PM => { 'Test::More' => '0.41' },
INSTALLDIRS => $] >= 5.007 ? 'perl' : 'site',
diff -urpN perl-5.10.0.orig/ext/Storable/Storable.pm perl-5.10.0/ext/Storable/Storable.pm
--- perl-5.10.0.orig/ext/Storable/Storable.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Storable/Storable.pm 2009-10-01 13:17:58.000000000 +0200
@@ -23,7 +23,7 @@ use AutoLoader;
use FileHandle;
use vars qw($canonical $forgive_me $VERSION);
-$VERSION = '2.18';
+$VERSION = '2.21';
*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr...
#
@@ -1177,7 +1177,7 @@ Storable was written by Raphael Manfredi
Maintenance is now done by the perl5-porters F<E<lt>perl5-porters@perl.orgE<gt>>
Please e-mail us with problems, bug fixes, comments and complaints,
-although if you have complements you should send them to Raphael.
+although if you have compliments you should send them to Raphael.
Please don't e-mail Raphael with problems, as he no longer works on
Storable, and your message will be delayed while he forwards it to us.
diff -urpN perl-5.10.0.orig/ext/Storable/Storable.xs perl-5.10.0/ext/Storable/Storable.xs
--- perl-5.10.0.orig/ext/Storable/Storable.xs 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Storable/Storable.xs 2009-10-01 13:17:58.000000000 +0200
@@ -151,7 +151,7 @@ typedef double NV; /* Older perls lack
#define TRACEME(x) \
STMT_START { \
- if (SvTRUE(perl_get_sv("Storable::DEBUGME", TRUE))) \
+ if (SvTRUE(perl_get_sv("Storable::DEBUGME", GV_ADD))) \
{ PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
} STMT_END
#else
@@ -401,7 +401,7 @@ typedef struct stcxt {
#if (PATCHLEVEL <= 4) && (SUBVERSION < 68)
#define dSTCXT_SV \
- SV *perinterp_sv = perl_get_sv(MY_VERSION, FALSE)
+ SV *perinterp_sv = perl_get_sv(MY_VERSION, 0)
#else /* >= perl5.004_68 */
#define dSTCXT_SV \
SV *perinterp_sv = *hv_fetch(PL_modglobal, \
@@ -1682,7 +1682,7 @@ static SV *pkg_fetchmeth(
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
GV *gv;
SV *sv;
@@ -1722,7 +1722,7 @@ static void pkg_hide(
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
const char *hvname = HvNAME_get(pkg);
(void) hv_store(cache,
@@ -1738,7 +1738,7 @@ static void pkg_uncache(
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
const char *hvname = HvNAME_get(pkg);
(void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD);
@@ -1756,7 +1756,7 @@ static SV *pkg_can(
pTHX_
HV *cache,
HV *pkg,
- char *method)
+ const char *method)
{
SV **svh;
SV *sv;
@@ -2332,7 +2332,7 @@ static int store_hash(pTHX_ stcxt_t *cxt
if (
!(cxt->optype & ST_CLONE) && (cxt->canonical == 1 ||
(cxt->canonical < 0 && (cxt->canonical =
- (SvTRUE(perl_get_sv("Storable::canonical", TRUE)) ? 1 : 0))))
+ (SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0))))
) {
/*
* Storing in order, sorted by key.
@@ -2619,7 +2619,7 @@ static int store_code(pTHX_ stcxt_t *cxt
if (
cxt->deparse == 0 ||
(cxt->deparse < 0 && !(cxt->deparse =
- SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0))
+ SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0))
) {
return store_other(aTHX_ cxt, (SV*)cv);
}
@@ -3397,7 +3397,7 @@ static int store_other(pTHX_ stcxt_t *cx
if (
cxt->forgive_me == 0 ||
(cxt->forgive_me < 0 && !(cxt->forgive_me =
- SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
+ SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
)
CROAK(("Can't store %s items", sv_reftype(sv, FALSE)));
@@ -3434,7 +3434,9 @@ static int sv_type(pTHX_ SV *sv)
{
switch (SvTYPE(sv)) {
case SVt_NULL:
+#if PERL_VERSION <= 10
case SVt_IV:
+#endif
case SVt_NV:
/*
* No need to check for ROK, that can't be set here since there
@@ -3442,7 +3444,11 @@ static int sv_type(pTHX_ SV *sv)
*/
return svis_SCALAR;
case SVt_PV:
+#if PERL_VERSION <= 10
case SVt_RV:
+#else
+ case SVt_IV:
+#endif
case SVt_PVIV:
case SVt_PVNV:
/*
@@ -3683,7 +3689,7 @@ static int magic_write(pTHX_ stcxt_t *cx
length = sizeof (network_file_header);
} else {
#ifdef USE_56_INTERWORK_KLUDGE
- if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) {
+ if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) {
header = file_header_56;
length = sizeof (file_header_56);
} else
@@ -4444,7 +4450,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *
* into the existing design. -- RAM, 17/02/2001
*/
- sv_magic(sv, rv, mtype, Nullch, 0);
+ sv_magic(sv, rv, mtype, (char *)NULL, 0);
SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */
return sv;
@@ -4497,7 +4503,7 @@ static SV *retrieve_ref(pTHX_ stcxt_t *c
if (cname) {
/* No need to do anything, as rv will already be PVMG. */
- assert (SvTYPE(rv) >= SVt_RV);
+ assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV);
} else {
sv_upgrade(rv, SVt_RV);
}
@@ -4561,7 +4567,7 @@ static SV *retrieve_overloaded(pTHX_ stc
* WARNING: breaks RV encapsulation.
*/
- sv_upgrade(rv, SVt_RV);
+ SvUPGRADE(rv, SVt_RV);
SvRV_set(rv, sv); /* $rv = \$sv */
SvROK_on(rv);
@@ -4641,7 +4647,7 @@ static SV *retrieve_tied_array(pTHX_ stc
sv_upgrade(tv, SVt_PVAV);
AvREAL_off((AV *)tv);
- sv_magic(tv, sv, 'P', Nullch, 0);
+ sv_magic(tv, sv, 'P', (char *)NULL, 0);
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv)));
@@ -4669,7 +4675,7 @@ static SV *retrieve_tied_hash(pTHX_ stcx
return (SV *) 0; /* Failed */
sv_upgrade(tv, SVt_PVHV);
- sv_magic(tv, sv, 'P', Nullch, 0);
+ sv_magic(tv, sv, 'P', (char *)NULL, 0);
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv)));
@@ -4701,7 +4707,7 @@ static SV *retrieve_tied_scalar(pTHX_ st
}
sv_upgrade(tv, SVt_PVMG);
- sv_magic(tv, obj, 'q', Nullch, 0);
+ sv_magic(tv, obj, 'q', (char *)NULL, 0);
if (obj) {
/* Undo refcnt inc from sv_magic() */
@@ -4768,7 +4774,7 @@ static SV *retrieve_tied_idx(pTHX_ stcxt
RLEN(idx); /* Retrieve <idx> */
sv_upgrade(tv, SVt_PVMG);
- sv_magic(tv, sv, 'p', Nullch, idx);
+ sv_magic(tv, sv, 'p', (char *)NULL, idx);
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */
return tv;
@@ -4907,7 +4913,7 @@ static SV *retrieve_utf8str(pTHX_ stcxt_
#else
if (cxt->use_bytes < 0)
cxt->use_bytes
- = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+ = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
? 1 : 0);
if (cxt->use_bytes == 0)
UTF8_CROAK();
@@ -4936,7 +4942,7 @@ static SV *retrieve_lutf8str(pTHX_ stcxt
#else
if (cxt->use_bytes < 0)
cxt->use_bytes
- = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+ = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
? 1 : 0);
if (cxt->use_bytes == 0)
UTF8_CROAK();
@@ -5267,7 +5273,7 @@ static SV *retrieve_flag_hash(pTHX_ stcx
if (hash_flags & SHV_RESTRICTED) {
if (cxt->derestrict < 0)
cxt->derestrict
- = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", TRUE))
+ = (SvTRUE(perl_get_sv("Storable::downgrade_restricted", GV_ADD))
? 1 : 0);
if (cxt->derestrict == 0)
RESTRICTED_HASH_CROAK();
@@ -5336,7 +5342,7 @@ static SV *retrieve_flag_hash(pTHX_ stcx
#else
if (cxt->use_bytes < 0)
cxt->use_bytes
- = (SvTRUE(perl_get_sv("Storable::drop_utf8", TRUE))
+ = (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD))
? 1 : 0);
if (cxt->use_bytes == 0)
UTF8_CROAK();
@@ -5437,14 +5443,14 @@ static SV *retrieve_code(pTHX_ stcxt_t *
*/
if (cxt->eval == NULL) {
- cxt->eval = perl_get_sv("Storable::Eval", TRUE);
+ cxt->eval = perl_get_sv("Storable::Eval", GV_ADD);
SvREFCNT_inc(cxt->eval);
}
if (!SvTRUE(cxt->eval)) {
if (
cxt->forgive_me == 0 ||
(cxt->forgive_me < 0 && !(cxt->forgive_me =
- SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
+ SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0))
) {
CROAK(("Can't eval, please set $Storable::Eval to a true value"));
} else {
@@ -5459,7 +5465,7 @@ static SV *retrieve_code(pTHX_ stcxt_t *
SAVETMPS;
if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
- SV* errsv = get_sv("@", TRUE);
+ SV* errsv = get_sv("@", GV_ADD);
sv_setpvn(errsv, "", 0); /* clear $@ */
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVsv(sub)));
@@ -5771,7 +5777,7 @@ static SV *magic_check(pTHX_ stcxt_t *cx
if (cxt->accept_future_minor < 0)
cxt->accept_future_minor
= (SvTRUE(perl_get_sv("Storable::accept_future_minor",
- TRUE))
+ GV_ADD))
? 1 : 0);
if (cxt->accept_future_minor == 1)
croak_now = 0; /* Don't croak yet. */
@@ -5808,7 +5814,7 @@ static SV *magic_check(pTHX_ stcxt_t *cx
#ifdef USE_56_INTERWORK_KLUDGE
/* No point in caching this in the context as we only need it once per
retrieve, and we need to recheck it each read. */
- if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", TRUE))) {
+ if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) {
if ((c != (sizeof (byteorderstr_56) - 1))
|| memNE(buf, byteorderstr_56, c))
CROAK(("Byte order is not compatible"));
@@ -5942,7 +5948,7 @@ static SV *retrieve(pTHX_ stcxt_t *cxt,
if (cxt->accept_future_minor < 0)
cxt->accept_future_minor
= (SvTRUE(perl_get_sv("Storable::accept_future_minor",
- TRUE))
+ GV_ADD))
? 1 : 0);
if (cxt->accept_future_minor == 1) {
CROAK(("Storable binary image v%d.%d contains data of type %d. "
diff -urpN perl-5.10.0.orig/ext/Storable/hints/hpux.pl perl-5.10.0/ext/Storable/hints/hpux.pl
--- perl-5.10.0.orig/ext/Storable/hints/hpux.pl 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Storable/hints/hpux.pl 2009-10-01 13:17:58.000000000 +0200
@@ -0,0 +1,10 @@
+# HP C-ANSI-C has problems in the optimizer for 5.8.x (not for 5.11.x)
+# So drop to -O1 for Storable
+
+use Config;
+
+unless ($Config{gccversion}) {
+ my $optimize = $Config{optimize};
+ $optimize =~ s/(^| )[-+]O[2-9]( |$)/$1+O1$2/ and
+ $self->{OPTIMIZE} = $optimize;
+ }
diff -urpN perl-5.10.0.orig/ext/Storable/t/overload.t perl-5.10.0/ext/Storable/t/overload.t
--- perl-5.10.0.orig/ext/Storable/t/overload.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Storable/t/overload.t 2009-10-01 13:17:58.000000000 +0200
@@ -25,7 +25,7 @@ sub ok;
use Storable qw(freeze thaw);
-print "1..16\n";
+print "1..19\n";
package OVERLOADED;
@@ -103,4 +103,17 @@ ok 13, $@ eq "";
ok 14, ref ($t) eq 'REF';
ok 15, ref ($$t) eq 'HAS_OVERLOAD';
ok 16, $$$t eq 'snow';
+
+
+#---
+# blessed reference to overloded object.
+{
+ my $a = bless [88], 'OVERLOADED';
+ my $c = thaw freeze bless \$a, 'main';
+ ok 17, ref $c eq 'main';
+ ok 18, ref $$c eq 'OVERLOADED';
+ ok 19, "$$c" eq "88";
+
+}
+
1;

View File

@ -1,965 +0,0 @@
Sys-Syslog-0.27
diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST
--- perl-5.10.0.orig/MANIFEST 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/MANIFEST 2009-02-10 11:14:14.000000000 +0100
@@ -1081,6 +1081,7 @@
ext/Sys/Syslog/Changes Changlog for Sys::Syslog
ext/Sys/Syslog/fallback/const-c.inc Sys::Syslog constants fallback file
ext/Sys/Syslog/fallback/const-xs.inc Sys::Syslog constants fallback file
+ext/Sys/Syslog/fallback/syslog.h Sys::Syslog fallback file
ext/Sys/Syslog/Makefile.PL Sys::Syslog extension makefile writer
ext/Sys/Syslog/README README for Sys::Syslog
ext/Sys/Syslog/README.win32 README for Sys::Syslog on Windows
@@ -1088,6 +1089,7 @@
ext/Sys/Syslog/Syslog.xs Sys::Syslog extension external subroutines
ext/Sys/Syslog/t/00-load.t test for Sys::Syslog
ext/Sys/Syslog/t/constants.t test for Sys::Syslog
+ext/Sys/Syslog/t/data-validation.t test for Sys::Syslog
ext/Sys/Syslog/t/syslog.t See if Sys::Syslog works
ext/Sys/Syslog/win32/compile.pl Sys::Syslog extension Win32 related file
ext/Sys/Syslog/win32/PerlLog_dll.uu Sys::Syslog extension Win32 related file
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/Changes perl-5.10.0/ext/Sys/Syslog/Changes
--- perl-5.10.0.orig/ext/Sys/Syslog/Changes 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/Changes 2009-02-10 11:10:19.000000000 +0100
@@ -1,5 +1,41 @@
Revision history for Sys-Syslog
+0.27 -- 2008.09.21 -- Sebastien Aperghis-Tramoni (SAPER)
+ [BUGFIX] Fixed compilation on Win32, thanks to Serguei Trouchelle.
+ Also added stubs so calling the XS functions will never fail.
+ [TESTS] t/pod.t now also uses Pod::Checker.
+
+0.26 -- 2008.06.16 -- Sebastien Aperghis-Tramoni (SAPER)
+ [BUGFIX] Make Sys::Syslog works with Perl 5.10.0 (because of
+ ExtUtils::Constant::ProxySubs).
+ [CODE] setlogsock() is now a little more strict about its arguments.
+
+0.25 -- 2008.05.17 -- Sebastien Aperghis-Tramoni (SAPER)
+ [BUGFIX] CPAN-RT#34691: Fixed an incorrect call to sysopen() which
+ prevented Sys::Syslog from working on some Solaris systems.
+ Thanks to Paul Townsend.
+ [BUGFIX] CPAN-RT#34753: Fixed a slowness introduced in v0.19 (which
+ was to work around OSX syslog own slowness). Thanks to Alex Efros.
+ [BUGFIX] CPAN-RT#35952: Fixed a bug with the "nofatal" option.
+ [BUGFIX] CPAN-RT#35189: Fixed a bug in xlate().
+ [BUGFIX] Fixed build on Win32, thanks to Adam Kennedy.
+ [FEATURE] setlogsock() now interprets the second argument as the
+ hostname for network mechanisms.
+ [DIST] Add AUTHOR to WriteMakefile() in order to fix the META.yml
+ generated by ExtUtils::MakeMaker.
+ [TESTS] Improved t/pod.t with Pod::Checker.
+
+0.24 -- 2007.12.31 -- Sebastien Aperghis-Tramoni (SAPER)
+ [BUGFIX] CPANT-RT#32001: Skip the setlogsock('stream') tests when
+ /dev/log is unavailable (Brendan O'Dea).
+
+0.23 -- 2007.11.12 -- Sebastien Aperghis-Tramoni (SAPER)
+ [BUGFIX] Fixed a too liberal test in the "pipe" mechanism, thanks
+ to Jan Dubois.
+ [DIST] fallback/syslog.h was missing from MANIFEST (thanks to CPAN
+ Tester Matthew Musgrove).
+ [TESTS] Better handling of Perl 5.005, thanks to CPAN Tester Slaven Rezic.
+
0.22 -- 2007.11.08 -- Sebastien Aperghis-Tramoni (SAPER)
[BUGFIX] CPAN-RT#29875: Added workaround SpamAssassin overzealous
logging features.
@@ -33,6 +69,8 @@
via syslog().
[BUGFIX] Rewrote the constants generation code in order to provide
fallback value for non-standard macros.
+ [BUGFIX] Mark Blackman and Edmund von der Burg identified and fixed the
+ random failures appearing on OSX, caused by a UDP timeout.
[FEATURE] Added Win32 event log support thanks to Yves Orton.
[FEATURE] Added new macros from modern BSD and IRIX.
[FEATURE] Each non-standard macro now fall backs to a standard macro.
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/Makefile.PL perl-5.10.0/ext/Sys/Syslog/Makefile.PL
--- perl-5.10.0.orig/ext/Sys/Syslog/Makefile.PL 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/Makefile.PL 2009-02-10 11:10:19.000000000 +0100
@@ -29,11 +29,14 @@
print " * Win32::EventLog detected.\n";
my $name = "PerlLog";
- push @extra_prereqs, "Win32::TieRegistry" => 0, "Win32::EventLog" => 0;
+ push @extra_prereqs,
+ Win32 => 0, "Win32::TieRegistry" => 0, "Win32::EventLog" => 0;
$virtual_path{'win32/Win32.pm' } = '$(INST_LIBDIR)/Syslog/Win32.pm';
$virtual_path{'win32/PerlLog.dll'} = '$(INST_ARCHAUTODIR)/PerlLog.dll';
+ push @extra_params, CCFLAGS => "-Ifallback";
+
# recreate the DLL from its uuencoded form if it's not here
if (! -f File::Spec->catfile("win32", "$name.dll")) {
# read the uuencoded data
@@ -70,22 +73,37 @@
DEFINE => '-DUSE_PPPORT_H';
}
+# on pre-5.6 Perls, add warnings::compat to the prereq modules
+push @extra_prereqs, "warnings::compat" => "0.06" if $] < 5.006;
+
WriteMakefile(
NAME => 'Sys::Syslog',
LICENSE => 'perl',
+ AUTHOR => 'Sebastien Aperghis-Tramoni <sebastien@aperghis.net>',
VERSION_FROM => 'Syslog.pm',
ABSTRACT_FROM => 'Syslog.pm',
INSTALLDIRS => 'perl',
XSPROTOARG => '-noprototypes',
PM => \%virtual_path,
PREREQ_PM => {
- 'Test::More' => 0,
- 'XSLoader' => 0,
+ # run prereqs
+ 'Carp' => 0,
+ 'Fcntl' => 0,
+ 'File::Basename' => 0,
+ 'File::Spec' => 0,
+ 'POSIX' => 0,
+ 'Socket' => 0,
+ 'XSLoader' => 0,
@extra_prereqs,
+
+ # build/test prereqs
+ 'Test::More' => 0,
},
+ PL_FILES => {},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => 'Sys-Syslog-*' },
- realclean => { FILES => 'lib const-c.inc const-xs.inc macros.all PerlLog.h *.bak *.bin *.rc' },
+ realclean => { FILES => 'lib const-c.inc const-xs.inc macros.all '
+ .'PerlLog.h typemap *.bak *.bin *.rc win32/PerlLog_dll' },
@extra_params
);
@@ -160,9 +178,9 @@
);
ExtUtils::Constant::WriteConstants(
- ($] > 5.009002 ? (PROXYSUBS => 1) : ()),
NAME => 'Sys::Syslog',
NAMES => [ @levels, @facilities, @options, @others_macros ],
+ ($] > 5.009002 ? (PROXYSUBS => 1) : ()),
);
my @names = map { ref $_ ? $_->{name} : $_ } @levels, @facilities, @options;
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/README perl-5.10.0/ext/Sys/Syslog/README
--- perl-5.10.0.orig/ext/Sys/Syslog/README 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/README 2009-02-10 11:10:19.000000000 +0100
@@ -63,5 +63,7 @@
COPYRIGHT AND LICENCE
+ Copyright (C) 1990-2008 by Larry Wall and others.
+
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/Syslog.pm perl-5.10.0/ext/Sys/Syslog/Syslog.pm
--- perl-5.10.0.orig/ext/Sys/Syslog/Syslog.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/Syslog.pm 2009-02-10 11:10:19.000000000 +0100
@@ -1,16 +1,17 @@
package Sys::Syslog;
use strict;
+use warnings;
use warnings::register;
use Carp;
+use Exporter ();
use Fcntl qw(O_WRONLY);
use File::Basename;
use POSIX qw(strftime setlocale LC_TIME);
use Socket ':all';
require 5.005;
-require Exporter;
{ no strict 'vars';
- $VERSION = '0.22';
+ $VERSION = '0.27';
@ISA = qw(Exporter);
%EXPORT_TAGS = (
@@ -76,6 +77,11 @@
#
use vars qw($host); # host to send syslog messages to (see notes at end)
+#
+# Prototypes
+#
+sub silent_eval (&);
+
#
# Global variables
#
@@ -85,6 +91,7 @@
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
@@ -105,15 +112,12 @@
@connectMethods = grep { $_ ne 'udp' } @connectMethods;
}
+# And on Win32 systems, we try to use the native mechanism for this
+# platform, the events logger, available through Win32::EventLog.
EVENTLOG: {
- # use EventLog on Win32
my $is_Win32 = $^O =~ /Win32/i;
- # some applications are trying to be too smart
- # yes I'm speaking of YOU, SpamAssassin, grr..
- local($SIG{__DIE__}, $SIG{__WARN__}, $@);
-
- if (eval "use Sys::Syslog::Win32; 1") {
+ if (can_load("Sys::Syslog::Win32")) {
unshift @connectMethods, 'eventlog';
}
elsif ($is_Win32) {
@@ -124,6 +128,18 @@
my @defaultMethods = @connectMethods;
my @fallbackMethods = ();
+# The timeout in connection_ok() was pushed up to 0.25 sec in
+# Sys::Syslog v0.19 in order to address a heisenbug on MacOSX:
+# http://london.pm.org/pipermail/london.pm/Week-of-Mon-20061211/005961.html
+#
+# However, this also had the effect of slowing this test for
+# all other operating systems, which apparently impacted some
+# users (cf. CPAN-RT #34753). So, in order to make everybody
+# 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.
+$sock_timeout = 0.25 if $^O =~ /darwin/;
+
# coderef for a nicer handling of errors
my $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
@@ -155,7 +171,7 @@
$options{$opt} = 1 if exists $options{$opt}
}
- $err_sub = $options{nofatal} ? \&warnings::warnif : \&croak;
+ $err_sub = delete $options{nofatal} ? \&warnings::warnif : \&croak;
return 1 unless $options{ndelay};
connect_log();
}
@@ -172,8 +188,18 @@
}
sub setlogsock {
- my $setsock = shift;
- $syslog_path = shift;
+ 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;
+
+ $syslog_path = $setpath if defined $setpath;
+ $sock_timeout = $settime if defined $settime;
+
disconnect_log() if $connected;
$transmit_ok = 0;
@fallbackMethods = ();
@@ -221,7 +247,7 @@
} elsif (lc $setsock eq 'pipe') {
for my $path ($syslog_path, &_PATH_LOG, "/dev/log") {
- next unless defined $path and length $path and -w $path;
+ next unless defined $path and length $path and -p $path and -w _;
$syslog_path = $path;
last
}
@@ -237,7 +263,7 @@
@connectMethods = qw(native);
} elsif (lc $setsock eq 'eventlog') {
- if (eval "use Win32::EventLog; 1") {
+ if (can_load("Win32::EventLog")) {
@connectMethods = qw(eventlog);
} else {
warnings::warnif "eventlog passed to setlogsock, but no Win32 API available";
@@ -248,6 +274,7 @@
} 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;
@@ -256,6 +283,7 @@
} 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;
@@ -268,8 +296,7 @@
@connectMethods = qw(console);
} else {
- croak "Invalid argument passed to setlogsock; must be 'stream', 'pipe', ",
- "'unix', 'native', 'eventlog', 'tcp', 'udp' or 'inet'"
+ croak $diag_invalid_arg
}
return 1;
@@ -293,25 +320,29 @@
croak "syslog: expecting argument \$priority" unless defined $priority;
croak "syslog: expecting argument \$format" unless defined $mask;
+ croak "syslog: invalid level/facility: $priority" if $priority =~ /^-\d+$/;
@words = split(/\W+/, $priority, 2); # Allow "level" or "level|facility".
undef $numpri;
undef $numfac;
- foreach (@words) {
- $num = xlate($_); # Translate word to number.
- if ($num < 0) {
- croak "syslog: invalid level/facility: $_"
- }
- elsif ($num <= &LOG_PRIMASK) {
- croak "syslog: too many levels given: $_" if defined $numpri;
- $numpri = $num;
- return 0 unless LOG_MASK($numpri) & $maskpri;
- }
- else {
- croak "syslog: too many facilities given: $_" if defined $numfac;
- $facility = $_;
- $numfac = $num;
- }
+ for my $word (@words) {
+ next if length $word == 0;
+
+ $num = xlate($word); # Translate word to number.
+
+ 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;
+ }
}
croak "syslog: level must be given" unless defined $numpri;
@@ -464,14 +495,28 @@
# private function to translate names to numeric values
#
sub xlate {
- my($name) = @_;
+ my ($name) = @_;
+
return $name+0 if $name =~ /^\s*\d+\s*$/;
$name = uc $name;
$name = "LOG_$name" unless $name =~ /^LOG_/;
- $name = "Sys::Syslog::$name";
- # Can't have just eval { &$name } || -1 because some LOG_XXX may be zero.
- my $value = eval { no strict 'refs'; &$name };
- $@ = "";
+
+ # ExtUtils::Constant 0.20 introduced a new way to implement
+ # constants, called ProxySubs. When it was used to generate
+ # the C code, the constant() function no longer returns the
+ # correct value. Therefore, we first try a direct call to
+ # constant(), and if the value is an error we try to call the
+ # constant by its full name.
+ my $value = constant($name);
+
+ if (index($value, "not a valid") >= 0) {
+ $name = "Sys::Syslog::$name";
+ $value = eval { no strict "refs"; &$name };
+ $value = $@ unless defined $value;
+ }
+
+ $value = -1 if index($value, "not a valid") >= 0;
+
return defined $value ? $value : -1;
}
@@ -546,11 +591,10 @@
}
setsockopt(SYSLOG, SOL_SOCKET, SO_KEEPALIVE, 1);
- if (eval { IPPROTO_TCP() }) {
+ if (silent_eval { IPPROTO_TCP() }) {
# These constants don't exist in 5.005. They were added in 1999
setsockopt(SYSLOG, IPPROTO_TCP(), TCP_NODELAY(), 1);
}
- $@ = "";
if (!connect(SYSLOG, $addr)) {
push @$errs, "tcp connect: $!";
return 0;
@@ -619,7 +663,7 @@
push @$errs, "stream $syslog_path is not writable";
return 0;
}
- if (!sysopen(SYSLOG, $syslog_path, 0400, O_WRONLY)) {
+ if (!sysopen(SYSLOG, $syslog_path, O_WRONLY, 0400)) {
push @$errs, "stream can't open $syslog_path: $!";
return 0;
}
@@ -697,12 +741,7 @@
$logopt += xlate($opt) if $options{$opt}
}
- eval { openlog_xs($ident, $logopt, xlate($facility)) };
- if ($@) {
- push @$errs, $@;
- return 0;
- }
-
+ openlog_xs($ident, $logopt, xlate($facility));
$syslog_send = \&_syslog_send_native;
return 1;
@@ -741,7 +780,7 @@
my $rin = '';
vec($rin, fileno(SYSLOG), 1) = 1;
- my $ret = select $rin, undef, $rin, 0.25;
+ my $ret = select $rin, undef, $rin, $sock_timeout;
return ($ret ? 0 : 1);
}
@@ -761,7 +800,26 @@
return close SYSLOG;
}
-1;
+
+#
+# Wrappers around eval() that makes sure that nobody, and I say NOBODY,
+# ever knows that I wanted to test if something was here or not.
+# It is needed because some applications are trying to be too smart,
+# do it wrong, and it ends up in EPIC FAIL.
+# Yes I'm speaking of YOU, SpamAssassin.
+#
+sub silent_eval (&) {
+ local($SIG{__DIE__}, $SIG{__WARN__}, $@);
+ return eval { $_[0]->() }
+}
+
+sub can_load {
+ local($SIG{__DIE__}, $SIG{__WARN__}, $@);
+ return eval "use $_[0]; 1"
+}
+
+
+"Eighth Rule: read the documentation."
__END__
@@ -771,7 +829,7 @@
=head1 VERSION
-Version 0.22
+Version 0.27
=head1 SYNOPSIS
@@ -965,6 +1023,8 @@
=item B<setlogsock($sock_type, $stream_location)> (added in Perl 5.004_02)
+=item B<setlogsock($sock_type, $stream_location, $sock_timeout)> (added in 0.25)
+
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:
@@ -984,15 +1044,18 @@
=item *
C<"tcp"> - connect to a TCP socket, on the C<syslog/tcp> or C<syslogng/tcp>
-service.
+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.
+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.
+C<"inet"> - connect to an INET socket, either TCP or UDP, tried in that
+order. If defined, the second parameter is used as a hostname to connect to.
=item *
@@ -1026,7 +1089,8 @@
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<stream>, C<console>.
+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
mechanism to try if C<Win32::EventLog> is available.
@@ -1113,8 +1177,7 @@
Log to UDP port on C<$remotehost> instead of logging locally:
- setlogsock('udp');
- $Sys::Syslog::host = $remotehost;
+ setlogsock("udp", $remotehost);
openlog($program, 'ndelay', 'user');
syslog('info', 'something happened over here');
@@ -1342,16 +1405,19 @@
L<http://www.gnu.org/software/libc/manual/html_node/Syslog.html>
Solaris 10 documentation on syslog,
-L<http://docs.sun.com/app/docs/doc/816-5168/6mbb3hruo?a=view>
+L<http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view>
-IRIX 6.4 documentation on syslog,
-L<http://techpubs.sgi.com/library/tpl/cgi-bin/getdoc.cgi?coll=0640&db=man&fname=3c+syslog>
+Mac OS X documentation on syslog,
+L<http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/syslog.3.html>
+
+IRIX 6.5 documentation on syslog,
+L<http://techpubs.sgi.com/library/tpl/cgi-bin/getdoc.cgi?coll=0650&db=man&fname=3c+syslog>
AIX 5L 5.3 documentation on syslog,
L<http://publib.boulder.ibm.com/infocenter/pseries/v5r3/index.jsp?topic=/com.ibm.aix.basetechref/doc/basetrf2/syslog.htm>
HP-UX 11i documentation on syslog,
-L<http://docs.hp.com/en/B9106-90010/syslog.3C.html>
+L<http://docs.hp.com/en/B2355-60130/syslog.3C.html>
Tru64 5.1 documentation on syslog,
L<http://h30097.www3.hp.com/docs/base_doc/DOCUMENTATION/V51_HTML/MAN/MAN3/0193____.HTM>
@@ -1455,7 +1521,7 @@
=head1 COPYRIGHT
-Copyright (C) 1990-2007 by Larry Wall and others.
+Copyright (C) 1990-2008 by Larry Wall and others.
=head1 LICENSE
@@ -1518,6 +1584,9 @@
Links
-----
+Linux Fast-STREAMS
+- L<http://www.openss7.org/streams.html>
+
II12021: SYSLOGD HOWTO TCPIPINFO (z/OS, OS/390, MVS)
- L<http://www-1.ibm.com/support/docview.wss?uid=isg1II12021>
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/Syslog.xs perl-5.10.0/ext/Sys/Syslog/Syslog.xs
--- perl-5.10.0.orig/ext/Sys/Syslog/Syslog.xs 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/Syslog.xs 2009-02-10 11:10:19.000000000 +0100
@@ -1,3 +1,7 @@
+#if defined(_WIN32)
+# include <windows.h>
+#endif
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
@@ -9,13 +13,13 @@
#define HAVE_SYSLOG 1
#endif
-#if defined(I_SYSLOG) || PATCHLEVEL < 6
-#include <syslog.h>
-#endif
-
#if defined(_WIN32) && !defined(__CYGWIN__)
-#undef HAVE_SYSLOG
-#include "fallback/syslog.h"
+# undef HAVE_SYSLOG
+# include "fallback/syslog.h"
+#else
+# if defined(I_SYSLOG) || PATCHLEVEL < 6
+# include <syslog.h>
+# endif
#endif
static SV *ident_svptr;
@@ -126,7 +130,9 @@
INPUT:
int mask
CODE:
- setlogmask(mask);
+ RETVAL = setlogmask(mask);
+ OUTPUT:
+ RETVAL
void
closelog_xs()
@@ -135,4 +141,31 @@
if (SvREFCNT(ident_svptr))
SvREFCNT_dec(ident_svptr);
+#else /* HAVE_SYSLOG */
+
+void
+openlog_xs(ident, option, facility)
+ INPUT:
+ SV* ident
+ int option
+ int facility
+ CODE:
+
+void
+syslog_xs(priority, message)
+ INPUT:
+ int priority
+ const char * message
+ CODE:
+
+int
+setlogmask_xs(mask)
+ INPUT:
+ int mask
+ CODE:
+
+void
+closelog_xs()
+ CODE:
+
#endif /* HAVE_SYSLOG */
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/fallback/syslog.h perl-5.10.0/ext/Sys/Syslog/fallback/syslog.h
--- perl-5.10.0.orig/ext/Sys/Syslog/fallback/syslog.h 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/fallback/syslog.h 2009-02-10 11:10:19.000000000 +0100
@@ -0,0 +1,111 @@
+/*
+ * Copyright (c) 1982, 1986, 1988, 1993
+ * The Regents of the University of California. All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ *
+ * @(#)syslog.h 8.1 (Berkeley) 6/2/93
+ */
+
+#ifndef _SYS_SYSLOG_H
+#define _SYS_SYSLOG_H 1
+
+#define _PATH_LOG ""
+
+/*
+ * priorities/facilities are encoded into a single 32-bit quantity, where the
+ * bottom 3 bits are the priority (0-7) and the top 28 bits are the facility
+ * (0-big number). Both the priorities and the facilities map roughly
+ * one-to-one to strings in the syslogd(8) source code. This mapping is
+ * included in this file.
+ *
+ * priorities (these are ordered)
+ */
+#define LOG_EMERG 0 /* system is unusable */
+#define LOG_ALERT 1 /* action must be taken immediately */
+#define LOG_CRIT 2 /* critical conditions */
+#define LOG_ERR 3 /* error conditions */
+#define LOG_WARNING 4 /* warning conditions */
+#define LOG_NOTICE 5 /* normal but significant condition */
+#define LOG_INFO 6 /* informational */
+#define LOG_DEBUG 7 /* debug-level messages */
+
+#define LOG_PRIMASK 0x07 /* mask to extract priority part (internal) */
+ /* extract priority */
+#define LOG_PRI(p) ((p) & LOG_PRIMASK)
+#define LOG_MAKEPRI(fac, pri) (((fac) << 3) | (pri))
+
+/* facility codes */
+#define LOG_KERN (0<<3) /* kernel messages */
+#define LOG_USER (1<<3) /* random user-level messages */
+#define LOG_MAIL (2<<3) /* mail system */
+#define LOG_DAEMON (3<<3) /* system daemons */
+#define LOG_AUTH (4<<3) /* security/authorization messages */
+#define LOG_SYSLOG (5<<3) /* messages generated internally by syslogd */
+#define LOG_LPR (6<<3) /* line printer subsystem */
+#define LOG_NEWS (7<<3) /* network news subsystem */
+#define LOG_UUCP (8<<3) /* UUCP subsystem */
+#define LOG_CRON (9<<3) /* clock daemon */
+#define LOG_AUTHPRIV (10<<3) /* security/authorization messages (private) */
+#define LOG_FTP (11<<3) /* ftp daemon */
+#define LOG_NETINFO (12<<3) /* NetInfo */
+#define LOG_REMOTEAUTH (13<<3) /* remote authentication/authorization */
+#define LOG_INSTALL (14<<3) /* installer subsystem */
+#define LOG_RAS (15<<3) /* Remote Access Service (VPN / PPP) */
+#define LOG_LOCAL0 (16<<3) /* reserved for local use */
+#define LOG_LOCAL1 (17<<3) /* reserved for local use */
+#define LOG_LOCAL2 (18<<3) /* reserved for local use */
+#define LOG_LOCAL3 (19<<3) /* reserved for local use */
+#define LOG_LOCAL4 (20<<3) /* reserved for local use */
+#define LOG_LOCAL5 (21<<3) /* reserved for local use */
+#define LOG_LOCAL6 (22<<3) /* reserved for local use */
+#define LOG_LOCAL7 (23<<3) /* reserved for local use */
+#define LOG_LAUNCHD (24<<3) /* launchd - general bootstrap daemon */
+
+#define LOG_NFACILITIES 25 /* current number of facilities */
+#define LOG_FACMASK 0x03f8 /* mask to extract facility part */
+ /* facility of pri */
+#define LOG_FAC(p) (((p) & LOG_FACMASK) >> 3)
+
+/*
+ * arguments to setlogmask.
+ */
+#define LOG_MASK(pri) (1 << (pri)) /* mask for one priority */
+#define LOG_UPTO(pri) ((1 << ((pri)+1)) - 1) /* all priorities through pri */
+
+/*
+ * Option flags for openlog.
+ *
+ * LOG_ODELAY no longer does anything.
+ * LOG_NDELAY is the inverse of what it used to be.
+ */
+#define LOG_PID 0x01 /* log the pid with each message */
+#define LOG_CONS 0x02 /* log on the console if errors in sending */
+#define LOG_ODELAY 0x04 /* delay open until first syslog() (default) */
+#define LOG_NDELAY 0x08 /* don't delay open */
+#define LOG_NOWAIT 0x10 /* don't wait for console forks: DEPRECATED */
+#define LOG_PERROR 0x20 /* log to stderr as well */
+
+#endif /* sys/syslog.h */
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/t/00-load.t perl-5.10.0/ext/Sys/Syslog/t/00-load.t
--- perl-5.10.0.orig/ext/Sys/Syslog/t/00-load.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/t/00-load.t 2009-02-10 11:10:19.000000000 +0100
@@ -2,9 +2,7 @@
use strict;
use Test::More tests => 1;
-BEGIN {
- use_ok( 'Sys::Syslog' );
-}
+use_ok( 'Sys::Syslog' );
diag( "Testing Sys::Syslog $Sys::Syslog::VERSION, Perl $], $^X" )
unless $ENV{PERL_CORE};
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/t/data-validation.t perl-5.10.0/ext/Sys/Syslog/t/data-validation.t
--- perl-5.10.0.orig/ext/Sys/Syslog/t/data-validation.t 1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/t/data-validation.t 2009-02-10 11:10:19.000000000 +0100
@@ -0,0 +1,114 @@
+#!perl -w
+# --------------------------------------------------------------------
+# The aim of this test is to start a syslog server (TCP or UDP) using
+# the one available in POE, make Sys::Syslog connect to it by manually
+# select the corresponding mechanism, send some messages and, inside
+# the POE syslog server, check that these message are correctly crafted.
+# --------------------------------------------------------------------
+use strict;
+
+my $port;
+BEGIN {
+ # override getservbyname()
+ *CORE::GLOBAL::getservbyname = sub ($$) {
+ my @v = CORE::getservbyname($_[0], $_[1]);
+
+ if (@v) {
+ $v[2] = $port;
+ } else {
+ @v = ($_[0], "", $port, $_[1]);
+ }
+
+ return wantarray ? @v : $port
+ }
+}
+
+use File::Spec;
+use Test::More;
+use Socket;
+use Sys::Syslog qw(:standard :extended :macros);
+
+
+# check than POE is available
+plan skip_all => "POE is not available" unless eval "use POE; 1";
+
+# check than POE::Component::Server::Syslog is available
+plan skip_all => "POE::Component::Server::Syslog is not available"
+ unless eval "use POE::Component::Server::Syslog; 1";
+
+plan tests => 1;
+
+ $port = 5140;
+my $proto = "tcp";
+
+my $ident = "pocosyslog";
+my $text = "Close the world, txEn eht nepO.";
+
+
+$SIG{ALRM} = sub {
+ ok( 0, "test took too much time to execute" );
+ exit
+};
+alarm 30;
+
+my $pid = fork();
+
+if ($pid) {
+ # parent: setup a syslog server
+ POE::Component::Server::Syslog->spawn(
+ Alias => 'syslog',
+ Type => $proto,
+ BindAddress => '127.0.0.1',
+ BindPort => $port,
+ InputState => \&client_input,
+ ErrorState => \&client_error,
+ );
+
+ $SIG{CHLD} = sub { wait() };
+
+ POE::Kernel->run;
+}
+else {
+ # child: send a message to the syslog server setup in the parent
+ sleep 2;
+ openlog($ident, "ndelay,pid", "local0");
+ setlogsock($proto);
+ syslog(info => $text);
+ closelog();
+ exit
+}
+
+sub client_input {
+ my $message = $_[&ARG0];
+ delete $message->{'time'}; # too hazardous to test
+ my $nl = $^O =~ /darwin/ ? "" : "\n";
+
+ is_deeply(
+ $message,
+ {
+ host => scalar gethostbyaddr(inet_aton('127.0.0.1'), AF_INET),
+ pri => &LOG_LOCAL0 + &LOG_INFO,
+ facility => &LOG_LOCAL0 >> 3,
+ severity => &LOG_INFO,
+ msg => "$ident\[$pid]: $text$nl\0",
+ },
+ "checking syslog message"
+ );
+
+ POE::Kernel->post(syslog => "shutdown");
+ POE::Kernel->stop;
+}
+
+sub client_error {
+ my $message = $_[&ARG0];
+
+ require Data::Dumper;
+ $Data::Dumper::Indent = 0; $Data::Dumper::Indent = 0;
+ $Data::Dumper::Sortkeys = 1; $Data::Dumper::Sortkeys = 1;
+ fail "checking syslog message";
+ diag "[client_error] message = ", Data::Dumper::Dumper($message);
+
+ POE::Kernel->post(syslog => "shutdown");
+ POE::Kernel->stop;
+}
+
diff -urN perl-5.10.0.orig/ext/Sys/Syslog/t/syslog.t perl-5.10.0/ext/Sys/Syslog/t/syslog.t
--- perl-5.10.0.orig/ext/Sys/Syslog/t/syslog.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Sys/Syslog/t/syslog.t 2009-02-10 11:10:19.000000000 +0100
@@ -19,6 +19,10 @@
pack portable recursion redefine regexp severe signal substr
syntax taint uninitialized unpack untie utf8 void);
+# if someone is using warnings::compat, the previous trick won't work, so we
+# must manually disable warnings
+$^W = 0 if $] < 5.006;
+
my $is_Win32 = $^O =~ /win32/i;
my $is_Cygwin = $^O =~ /cygwin/i;
@@ -111,35 +115,35 @@
}
-BEGIN { $tests += 20 * 8 }
+BEGIN { $tests += 22 * 8 }
# try to open a syslog using all the available connection methods
my @passed = ();
for my $sock_type (qw(native eventlog unix pipe stream inet tcp udp)) {
SKIP: {
- skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 20
+ skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 22
if $sock_type eq 'stream' and grep {/pipe|unix/} @passed;
# setlogsock() called with an arrayref
$r = eval { setlogsock([$sock_type]) } || 0;
- skip "can't use '$sock_type' socket", 20 unless $r;
+ skip "can't use '$sock_type' socket", 22 unless $r;
is( $@, '', "[$sock_type] setlogsock() called with ['$sock_type']" );
ok( $r, "[$sock_type] setlogsock() should return true: '$r'" );
# setlogsock() called with a single argument
$r = eval { setlogsock($sock_type) } || 0;
- skip "can't use '$sock_type' socket", 18 unless $r;
+ skip "can't use '$sock_type' socket", 20 unless $r;
is( $@, '', "[$sock_type] setlogsock() called with '$sock_type'" );
ok( $r, "[$sock_type] setlogsock() should return true: '$r'" );
# openlog() without option NDELAY
$r = eval { openlog('perl', '', 'local0') } || 0;
- skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/;
+ skip "can't connect to syslog", 18 if $@ =~ /^no connection to syslog available/;
is( $@, '', "[$sock_type] openlog() called with facility 'local0' and without option 'ndelay'" );
ok( $r, "[$sock_type] openlog() should return true: '$r'" );
# openlog() with the option NDELAY
$r = eval { openlog('perl', 'ndelay', 'local0') } || 0;
- skip "can't connect to syslog", 14 if $@ =~ /^no connection to syslog available/;
+ skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/;
is( $@, '', "[$sock_type] openlog() called with facility 'local0' with option 'ndelay'" );
ok( $r, "[$sock_type] openlog() should return true: '$r'" );
@@ -148,6 +152,11 @@
like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level -1" );
ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
+ # syslog() with invalid level, should fail
+ $r = eval { syslog("plonk", "$test_string by connecting to a $sock_type socket") } || 0;
+ like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level plonk" );
+ ok( !$r, "[$sock_type] syslog() should return false: '$r'" );
+
# syslog() with levels "info" and "notice" (as a strings), should fail
$r = eval { syslog('info,notice', "$test_string by connecting to a $sock_type socket") } || 0;
like( $@, '/^syslog: too many levels given: notice/', "[$sock_type] syslog() called with level 'info,notice'" );
@@ -189,6 +198,9 @@
skip "the 'unix' mechanism works, so the tests will likely fail with the 'stream' mechanism", 10
if grep {/unix/} @passed;
+ skip "not testing setlogsock('stream'): _PATH_LOG unavailable", 10
+ unless -e Sys::Syslog::_PATH_LOG();
+
# setlogsock() with "stream" and an undef path
$r = eval { setlogsock("stream", undef ) } || '';
is( $@, '', "setlogsock() called, with 'stream' and an undef path" );

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -1,686 +0,0 @@
Time-HiRes-1.9719
diff -urN perl-5.10.0.orig/ext/Time/HiRes/Changes perl-5.10.0/ext/Time/HiRes/Changes
--- perl-5.10.0.orig/ext/Time/HiRes/Changes 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/Changes 2009-03-10 17:48:02.000000000 +0100
@@ -1,5 +1,66 @@
Revision history for the Perl extension Time::HiRes.
+1.9719 [2009-01-04]
+ - As with QNX, Haiku has the API of interval timers but not
+ the implementation (bleadperl change #34630), hence skip
+ the tests, via David Mitchell.
+
+1.9718 [2008-12-31]
+ - .xs code cleanup from Albert Dvornik
+ - in the #39 and #40 do not do us I did, mixing alarm() and
+ sleep(). Now instead spin until enough time has passed.
+
+1.9717 [2008-12-30]
+ - Skip the tests added in 1.9716 (#39, #40) if there's no subsecond
+ alarm capability, like with the older subsecond alarm tests
+
+1.9716 [2008-12-26]
+ - Change documentation to agree with reality: there are
+ no interval timers in Win32.
+ - Address [rt.cpan.org #35899] (problem in subsecond sleeps),
+ add two tests to guard against this problem
+ - Address [rt.cpan.org #36600] 'Division by zero' failure in test suite
+ - Address [rt.cpan.org #37340] [PATCH] Address timer process in test
+ - Address [rt.cpan.org#40311 ] bad implementation of hrt_usleep
+ with TIME_HIRES_NANOSLEEP
+
+1.9715 [2008-04-08]
+ - Silly me: Makefile.PL does need to accept arguments other than mine.
+ Some testing frameworks obviously do this.
+ - Add retrying for tests 34..37, which are the most commonly
+ failing tests. If this helps, consider extending the retry
+ framework to all the tests. [Inspired by Slaven Rezic,
+ [rt.cpan.org #34711] Occasional failures of test 35 or 36 (FreeBSD)]
+
+1.9714 [2008-04-07]
+ - Under Perl 5.6.* NVgf needs to be "g", reported by Zefram,
+ it seems that ppport.h 3.13 gets this wrong.
+ - remove the check in Makefile.PL for 5.7.2, shouldn't be
+ (a) necessary (b) relevant
+ - add logic to Makefile.PL to skip configure/write Makefile
+ step if the "xdefine" file already exists, indicating that
+ the configure step has already been done, one can still
+ force (re)configure by "perl Makefile.PL configure",
+ or of course by "make clean && perl Makefile.PL".
+
+1.9713 [2008-04-04]
+ - for alarm() and ualarm() [Perl] prefer setitimer() [C]
+ instead of ualarm() [C] since ualarm() [C] cannot portably
+ (and standards-compliantly) be used for more than 999_999
+ microseconds (rt.cpan.org #34655)
+ - it seems that HP-UX has started (at least in 11.31 ia64)
+ #defining the CLOCK_REALTIME et alia (instead of having
+ them just as enums)
+ - document all the diagnostics
+
+1.9712 [2008-02-09]
+ - move the sub tick in the test file back to where it used to be
+ - in the "consider upgrading" message recommend at least Perl 5.8.8
+ and make the message to appear only for 5.8.0 since 5.8.1 and
+ later have the problem fixed
+ - VOS tweak for Makefile (core perl change #33259)
+ - since the test #17 seems to fail often, relax its limits a bit
+
1.9711 [2007-11-29]
- lost VMS test skippage from Craig Berry
- reformat the test code a little
diff -urN perl-5.10.0.orig/ext/Time/HiRes/HiRes.pm perl-5.10.0/ext/Time/HiRes/HiRes.pm
--- perl-5.10.0.orig/ext/Time/HiRes/HiRes.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/HiRes.pm 2009-03-10 17:48:02.000000000 +0100
@@ -22,8 +22,8 @@
d_clock d_clock_nanosleep
stat
);
-
-$VERSION = '1.9711';
+
+$VERSION = '1.9719';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -209,6 +209,9 @@
Issues a C<ualarm> call; the C<$interval_useconds> is optional and
will be zero if unspecified, resulting in C<alarm>-like behaviour.
+Returns the remaining time in the alarm in microseconds, or C<undef>
+if an error occurred.
+
ualarm(0) will cancel an outstanding ualarm().
Note that the interaction between alarms and sleeps is unspecified.
@@ -260,10 +263,14 @@
=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
The C<SIGALRM> signal is sent after the specified number of seconds.
-Implemented using C<ualarm()>. The C<$interval_floating_seconds> argument
-is optional and will be zero if unspecified, resulting in C<alarm()>-like
-behaviour. This function can be imported, resulting in a nice drop-in
-replacement for the C<alarm> provided with perl, see the L</EXAMPLES> below.
+Implemented using C<setitimer()> if available, C<ualarm()> if not.
+The C<$interval_floating_seconds> argument is optional and will be
+zero if unspecified, resulting in C<alarm()>-like behaviour. This
+function can be imported, resulting in a nice drop-in replacement for
+the C<alarm> provided with perl, see the L</EXAMPLES> below.
+
+Returns the remaining time in the alarm in seconds, or C<undef>
+if an error occurred.
B<NOTE 1>: With some combinations of operating systems and Perl
releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
@@ -292,9 +299,9 @@
There are usually three or four interval timers (signals) available: the
C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
C<ITIMER_REALPROF>. Note that which ones are available depends: true
-UNIX platforms usually have the first three, but (for example) Win32
-and Cygwin have only C<ITIMER_REAL>, and only Solaris seems to have
-C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+UNIX platforms usually have the first three, but only Solaris seems to
+have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+Win32 unfortunately does not haveinterval timers.
C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in
I<real time>; that is, wallclock time. C<SIGALRM> is delivered when
@@ -337,8 +344,8 @@
CLOCK_REALTIME is zero, it might be one, or something else.
Another potentially useful (but not available everywhere) value is
C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
-value (unlike time(), which can be adjusted). See your system
-documentation for other possibly supported values.
+value (unlike time() or gettimeofday(), which can be adjusted).
+See your system documentation for other possibly supported values.
=item clock_getres ( $which )
@@ -528,6 +535,15 @@
Something went horribly wrong-- the number of microseconds that cannot
become negative just became negative. Maybe your compiler is broken?
+=head2 useconds or uinterval equal to or more than 1000000
+
+In some platforms it is not possible to get an alarm with subsecond
+resolution and later than one second.
+
+=head2 unimplemented in this platform
+
+Some calls simply aren't available, real or emulated, on every platform.
+
=head1 CAVEATS
Notice that the core C<time()> maybe rounding rather than truncating.
@@ -544,6 +560,9 @@
Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
might help in this (in case your system supports CLOCK_MONOTONIC).
+Some systems have APIs but not implementations: for example QNX and Haiku
+have the interval timer APIs but not the functionality.
+
=head1 SEE ALSO
Perl modules L<BSD::Resource>, L<Time::TAI64>.
@@ -563,7 +582,8 @@
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
-Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007 Jarkko Hietaniemi. All rights reserved.
+Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
+All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
diff -urN perl-5.10.0.orig/ext/Time/HiRes/HiRes.xs perl-5.10.0/ext/Time/HiRes/HiRes.xs
--- perl-5.10.0.orig/ext/Time/HiRes/HiRes.xs 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/HiRes.xs 2009-03-10 17:48:02.000000000 +0100
@@ -2,7 +2,8 @@
*
* Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
*
- * Copyright (c) 2002,2003,2004,2005,2006,2007 Jarkko Hietaniemi. All rights reserved.
+ * Copyright (c) 2002,2003,2004,2005,2006,2007,2008 Jarkko Hietaniemi.
+ * All rights reserved.
*
* This program is free software; you can redistribute it and/or modify
* it under the same terms as Perl itself.
@@ -37,6 +38,13 @@
}
#endif
+/* At least ppport.h 3.13 gets this wrong: one really cannot
+ * have NVgf as anything else than "g" under Perl 5.6.x. */
+#if PERL_REVISION == 5 && PERL_VERSION == 6
+# undef NVgf
+# define NVgf "g"
+#endif
+
#define IV_1E6 1000000
#define IV_1E7 10000000
#define IV_1E9 1000000000
@@ -71,9 +79,13 @@
/* HP-UX has CLOCK_XXX values but as enums, not as defines.
* The only way to detect these would be to test compile for each. */
# ifdef __hpux
-# define CLOCK_REALTIME CLOCK_REALTIME
-# define CLOCK_VIRTUAL CLOCK_VIRTUAL
-# define CLOCK_PROFILE CLOCK_PROFILE
+/* However, it seems that at least in HP-UX 11.31 ia64 there *are*
+ * defines for these, so let's try detecting them. */
+# ifndef CLOCK_REALTIME
+# define CLOCK_REALTIME CLOCK_REALTIME
+# define CLOCK_VIRTUAL CLOCK_VIRTUAL
+# define CLOCK_PROFILE CLOCK_PROFILE
+# endif
# endif /* # ifdef __hpux */
#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC) */
@@ -390,10 +402,10 @@
* The TIME_HIRES_NANOSLEEP is set by Makefile.PL. */
#if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP)
#define HAS_USLEEP
-#define usleep hrt_nanosleep /* could conflict with ncurses for static build */
+#define usleep hrt_usleep /* could conflict with ncurses for static build */
void
-hrt_nanosleep(unsigned long usec) /* This is used to emulate usleep. */
+hrt_usleep(unsigned long usec) /* This is used to emulate usleep. */
{
struct timespec res;
res.tv_sec = usec / IV_1E6;
@@ -433,21 +445,6 @@
}
#endif /* #if !defined(HAS_USLEEP) && defined(WIN32) */
-#if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP)
-#define HAS_USLEEP
-#define usleep hrt_usleep /* could conflict with ncurses for static build */
-
-void
-hrt_usleep(unsigned long usec)
-{
- struct timespec ts1;
- ts1.tv_sec = usec * 1000; /* Ignoring wraparound. */
- ts1.tv_nsec = 0;
- nanosleep(&ts1, NULL);
-}
-
-#endif /* #if !defined(HAS_USLEEP) && defined(TIME_HIRES_NANOSLEEP) */
-
#if !defined(HAS_USLEEP) && defined(HAS_POLL)
#define HAS_USLEEP
#define usleep hrt_usleep /* could conflict with ncurses for static build */
@@ -462,16 +459,24 @@
#endif /* #if !defined(HAS_USLEEP) && defined(HAS_POLL) */
#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
+
+static int
+hrt_ualarm_itimero(struct itimerval* itv, int usec, int uinterval)
+{
+ itv->it_value.tv_sec = usec / IV_1E6;
+ itv->it_value.tv_usec = usec % IV_1E6;
+ itv->it_interval.tv_sec = uinterval / IV_1E6;
+ itv->it_interval.tv_usec = uinterval % IV_1E6;
+ return setitimer(ITIMER_REAL, itv, 0);
+}
+
int
-hrt_ualarm_itimer(int usec, int interval)
+hrt_ualarm_itimer(int usec, int uinterval)
{
- struct itimerval itv;
- itv.it_value.tv_sec = usec / IV_1E6;
- itv.it_value.tv_usec = usec % IV_1E6;
- itv.it_interval.tv_sec = interval / IV_1E6;
- itv.it_interval.tv_usec = interval % IV_1E6;
- return setitimer(ITIMER_REAL, &itv, 0);
+ struct itimerval itv;
+ return hrt_ualarm_itimero(&itv, usec, uinterval);
}
+
#ifdef HAS_UALARM
int
hrt_ualarm(int usec, int interval) /* for binary compat before 1.91 */
@@ -898,21 +903,27 @@
#ifdef HAS_UALARM
-int
-ualarm(useconds,interval=0)
+IV
+ualarm(useconds,uinterval=0)
int useconds
- int interval
+ int uinterval
CODE:
- if (useconds < 0 || interval < 0)
- croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, interval);
- if (useconds >= IV_1E6 || interval >= IV_1E6)
+ if (useconds < 0 || uinterval < 0)
+ croak("Time::HiRes::ualarm(%d, %d): negative time not invented yet", useconds, uinterval);
#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
- RETVAL = hrt_ualarm_itimer(useconds, interval);
+ {
+ struct itimerval itv;
+ if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
+ RETVAL = itv.it_value.tv_sec + IV_1E6 * itv.it_value.tv_usec;
+ } else {
+ RETVAL = 0;
+ }
+ }
#else
- croak("Time::HiRes::ualarm(%d, %d): useconds or interval equal or more than %"IVdf, useconds, interval, IV_1E6);
+ if (useconds >= IV_1E6 || uinterval >= IV_1E6)
+ croak("Time::HiRes::ualarm(%d, %d): useconds or uinterval equal to or more than %"IVdf, useconds, uinterval, IV_1E6);
+ RETVAL = ualarm(useconds, uinterval);
#endif
- else
- RETVAL = ualarm(useconds, interval);
OUTPUT:
RETVAL
@@ -924,8 +935,24 @@
CODE:
if (seconds < 0.0 || interval < 0.0)
croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): negative time not invented yet", seconds, interval);
- RETVAL = (NV)ualarm((IV)(seconds * IV_1E6),
- (IV)(interval * IV_1E6)) / NV_1E6;
+ {
+ IV useconds = IV_1E6 * seconds;
+ IV uinterval = IV_1E6 * interval;
+#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
+ {
+ struct itimerval itv;
+ if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
+ RETVAL = (NV)itv.it_value.tv_sec + (NV)itv.it_value.tv_usec / NV_1E6;
+ } else {
+ RETVAL = 0;
+ }
+ }
+#else
+ if (useconds >= IV_1E6 || uinterval >= IV_1E6)
+ croak("Time::HiRes::alarm(%d, %d): seconds or interval equal to or more than 1.0 ", useconds, uinterval, IV_1E6);
+ RETVAL = (NV)ualarm( useconds, uinterval ) / NV_1E6;
+#endif
+ }
OUTPUT:
RETVAL
diff -urN perl-5.10.0.orig/ext/Time/HiRes/Makefile.PL perl-5.10.0/ext/Time/HiRes/Makefile.PL
--- perl-5.10.0.orig/ext/Time/HiRes/Makefile.PL 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/Makefile.PL 2009-03-10 17:48:02.000000000 +0100
@@ -19,8 +19,11 @@
use vars qw($self); # Used in 'sourcing' the hints.
+# TBD: Can we just use $Config(exe_ext) here instead of this complex
+# expression?
my $ld_exeext = ($^O eq 'cygwin' ||
- $^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' : '';
+ $^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' :
+ (($^O eq 'vos') ? $Config{exe_ext} : '');
unless($ENV{PERL_CORE}) {
$ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV;
@@ -829,38 +832,43 @@
}
sub main {
- print "Configuring Time::HiRes...\n";
- if ($] == 5.007002) {
- die "Cannot Configure Time::HiRes for Perl $], aborting.\n";
- }
-
- if ($^O =~ /Win32/i) {
- DEFINE('SELECT_IS_BROKEN');
- $LIBS = [];
- print "System is $^O, skipping full configure...\n";
- } else {
- init();
+ if (-f "xdefine" && !(@ARGV && $ARGV[0] eq '--configure')) {
+ print qq[$0: The "xdefine" exists, skipping the configure step.\n];
+ print qq[("$^X $0 --configure" to force the configure step)\n];
+ } else {
+ print "Configuring Time::HiRes...\n";
+ 1 while unlink("define");
+ if ($^O =~ /Win32/i) {
+ DEFINE('SELECT_IS_BROKEN');
+ $LIBS = [];
+ print "System is $^O, skipping full configure...\n";
+ open(XDEFINE, ">xdefine") or die "$0: Cannot create xdefine: $!\n";
+ close(XDEFINE);
+ } else {
+ init();
+ }
+ doMakefile;
+ doConstants;
}
- doMakefile;
- doConstants;
my $make = $Config{'make'} || "make";
unless (exists $ENV{PERL_CORE} && $ENV{PERL_CORE}) {
print <<EOM;
Now you may issue '$make'. Do not forget also '$make test'.
EOM
- if ((exists $ENV{LC_ALL} && $ENV{LC_ALL} =~ /utf-?8/i) ||
- (exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) ||
- (exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i)) {
+ if ($] == 5.008 &&
+ ((exists $ENV{LC_ALL} && $ENV{LC_ALL} =~ /utf-?8/i) ||
+ (exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) ||
+ (exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i))) {
print <<EOM;
NOTE: if you get an error like this (the Makefile line number may vary):
Makefile:91: *** missing separator
then set the environment variable LC_ALL to "C" and retry
from scratch (re-run perl "Makefile.PL").
-(And consider upgrading your Perl.)
+(And consider upgrading your Perl to, say, at least Perl 5.8.8.)
(You got this message because you seem to have
an UTF-8 locale active in your shell environment, this used
- to cause broken Makefiles to be created from Makefile.PLs.)
+ to cause broken Makefiles to be created from Makefile.PLs)
EOM
}
}
diff -urN perl-5.10.0.orig/ext/Time/HiRes/t/HiRes.t perl-5.10.0/ext/Time/HiRes/t/HiRes.t
--- perl-5.10.0.orig/ext/Time/HiRes/t/HiRes.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/ext/Time/HiRes/t/HiRes.t 2009-03-10 17:48:02.000000000 +0100
@@ -12,7 +12,7 @@
}
}
-BEGIN { $| = 1; print "1..38\n"; }
+BEGIN { $| = 1; print "1..40\n"; }
END { print "not ok 1\n" unless $loaded }
@@ -68,7 +68,7 @@
my $have_alarm = $Config{d_alarm};
my $have_fork = $Config{d_fork};
-my $waitfor = 180; # 30-45 seconds is normal (load affects this).
+my $waitfor = 360; # 30-45 seconds is normal (load affects this).
my $timer_pid;
my $TheEnd;
@@ -79,11 +79,14 @@
if ($timer_pid == 0) { # We are the kid, set up the timer.
my $ppid = getppid();
print "# I am the timer process $$, sleeping for $waitfor seconds...\n";
- sleep($waitfor);
- warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
- print "# Terminating main process $ppid...\n";
- kill('TERM', $ppid);
- print "# This is the timer process $$, over and out.\n";
+ sleep($waitfor - 2); # Workaround for perlbug #49073
+ sleep(2); # Wait for parent to exit
+ if (kill(0, $ppid)) { # Check if parent still exists
+ warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
+ print "# Terminating main process $ppid...\n";
+ kill('KILL', $ppid);
+ print "# This is the timer process $$, over and out.\n";
+ }
exit(0);
} else {
print "# The timer process $timer_pid launched, continuing testing...\n";
@@ -238,10 +241,13 @@
$has_ualarm ||= $xdefine =~ /-DHAS_UALARM/;
-unless ( defined &Time::HiRes::gettimeofday
- && defined &Time::HiRes::ualarm
- && defined &Time::HiRes::usleep
- && $has_ualarm) {
+my $can_subsecond_alarm =
+ defined &Time::HiRes::gettimeofday &&
+ defined &Time::HiRes::ualarm &&
+ defined &Time::HiRes::usleep &&
+ $has_ualarm;
+
+unless ($can_subsecond_alarm) {
for (15..17) {
print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n";
}
@@ -271,19 +277,6 @@
# Perl's deferred signals may be too wimpy to break through
# a restartable select(), so use POSIX::sigaction if available.
- sub tick {
- $i--;
- my $ival = Time::HiRes::tv_interval ($r);
- print "# Tick! $i $ival\n";
- my $exp = 0.3 * (5 - $i);
- # This test is more sensitive, so impose a softer limit.
- if (abs($ival/$exp - 1) > 4*$limit) {
- my $ratio = abs($ival/$exp);
- $not = "tick: $exp sleep took $ival ratio $ratio";
- $i = 0;
- }
- }
-
POSIX::sigaction(&POSIX::SIGALRM,
POSIX::SigAction->new("tick"),
$oldaction)
@@ -314,8 +307,12 @@
last;
}
my $exp = 0.3 * (5 - $i);
+ if ($exp == 0) {
+ $not = "while: divisor became zero";
+ last;
+ }
# This test is more sensitive, so impose a softer limit.
- if (abs($ival/$exp - 1) > 3*$limit) {
+ if (abs($ival/$exp - 1) > 4*$limit) {
my $ratio = abs($ival/$exp);
$not = "while: $exp sleep took $ival ratio $ratio";
last;
@@ -324,6 +321,23 @@
}
}
+ sub tick {
+ $i--;
+ my $ival = Time::HiRes::tv_interval ($r);
+ print "# Tick! $i $ival\n";
+ my $exp = 0.3 * (5 - $i);
+ if ($exp == 0) {
+ $not = "tick: divisor became zero";
+ last;
+ }
+ # This test is more sensitive, so impose a softer limit.
+ if (abs($ival/$exp - 1) > 4*$limit) {
+ my $ratio = abs($ival/$exp);
+ $not = "tick: $exp sleep took $ival ratio $ratio";
+ $i = 0;
+ }
+ }
+
if ($use_sigaction) {
POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
} else {
@@ -333,11 +347,13 @@
print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n";
}
-unless ( defined &Time::HiRes::setitimer
+unless (defined &Time::HiRes::setitimer
&& defined &Time::HiRes::getitimer
&& has_symbol('ITIMER_VIRTUAL')
&& $Config{sig_name} =~ m/\bVTALRM\b/
- && $^O !~ /^(nto)$/) { # nto: QNX 6 has the API but no implementation
+ && $^O ne 'nto' # nto: QNX 6 has the API but no implementation
+ && $^O ne 'haiku' # haiku: has the API but no implementation
+ ) {
for (18..19) {
print "ok $_ # Skip: no virtual interval timers\n";
}
@@ -502,13 +518,14 @@
};
# Next setup a periodic timer (the two-argument alarm() of
- # Time::HiRes, behind the curtains the libc ualarm()) which has
- # a signal handler that takes so much time (on the first initial
- # invocation) that the first periodic invocation (second invocation)
- # will happen before the first invocation has finished. In Perl 5.8.0
- # the "safe signals" concept was implemented, with unfortunately at least
- # one bug that caused a core dump on reentering the handler. This bug
- # was fixed by the time of Perl 5.8.1.
+ # Time::HiRes, behind the curtains the libc getitimer() or
+ # ualarm()) which has a signal handler that takes so much time (on
+ # the first initial invocation) that the first periodic invocation
+ # (second invocation) will happen before the first invocation has
+ # finished. In Perl 5.8.0 the "safe signals" concept was
+ # implemented, with unfortunately at least one bug that caused a
+ # core dump on reentering the handler. This bug was fixed by the
+ # time of Perl 5.8.1.
# Do not try mixing sleep() and alarm() for testing this.
@@ -620,6 +637,16 @@
skip 33;
}
+sub bellish { # Cheap emulation of a bell curve.
+ my ($min, $max) = @_;
+ my $rand = ($max - $min) / 5;
+ my $sum = 0;
+ for my $i (0..4) {
+ $sum += rand($rand);
+ }
+ return $min + $sum;
+}
+
if ($have_ualarm) {
# 1_100_000 sligthly over 1_000_000,
# 2_200_000 slightly over 2**31/1000,
@@ -629,21 +656,29 @@
[36, 2_200_000],
[37, 4_300_000]) {
my ($i, $n) = @$t;
- my $alarmed = 0;
- local $SIG{ ALRM } = sub { $alarmed++ };
- my $t0 = Time::HiRes::time();
- print "# t0 = $t0\n";
- print "# ualarm($n)\n";
- ualarm($n); 1 while $alarmed == 0;
- my $t1 = Time::HiRes::time();
- print "# t1 = $t1\n";
- my $dt = $t1 - $t0;
- print "# dt = $dt\n";
- my $r = $dt / ($n/1e6);
- print "# r = $r\n";
- ok $i,
- ($n < 1_000_000 || # Too much noise.
- $r >= 0.8 && $r <= 1.6), "ualarm($n) close enough";
+ my $ok;
+ for my $retry (1..10) {
+ my $alarmed = 0;
+ local $SIG{ ALRM } = sub { $alarmed++ };
+ my $t0 = Time::HiRes::time();
+ print "# t0 = $t0\n";
+ print "# ualarm($n)\n";
+ ualarm($n); 1 while $alarmed == 0;
+ my $t1 = Time::HiRes::time();
+ print "# t1 = $t1\n";
+ my $dt = $t1 - $t0;
+ print "# dt = $dt\n";
+ my $r = $dt / ($n/1e6);
+ print "# r = $r\n";
+ $ok =
+ ($n < 1_000_000 || # Too much noise.
+ ($r >= 0.8 && $r <= 1.6));
+ last if $ok;
+ my $nap = bellish(3, 15);
+ printf "# Retrying in %.1f seconds...\n", $nap;
+ Time::HiRes::sleep($nap);
+ }
+ ok $i, $ok, "ualarm($n) close enough";
}
} else {
print "# No ualarm\n";
@@ -710,12 +745,37 @@
skip 38;
}
+unless ($can_subsecond_alarm) {
+ skip 39..40;
+} else {
+ {
+ my $alrm;
+ $SIG{ALRM} = sub { $alrm++ };
+ Time::HiRes::alarm(0.1);
+ my $t0 = time();
+ 1 while time() - $t0 <= 1;
+ print $alrm ? "ok 39\n" : "not ok 39\n";
+ }
+ {
+ my $alrm;
+ $SIG{ALRM} = sub { $alrm++ };
+ Time::HiRes::alarm(1.1);
+ my $t0 = time();
+ 1 while time() - $t0 <= 2;
+ print $alrm ? "ok 40\n" : "not ok 40\n";
+ }
+}
+
END {
if ($timer_pid) { # Only in the main process.
my $left = $TheEnd - time();
printf "# I am the main process $$, terminating the timer process $timer_pid\n# before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left;
- my $kill = kill('TERM', $timer_pid); # We are done, the timer can go.
- printf "# kill TERM $timer_pid = %d\n", $kill;
+ if (kill(0, $timer_pid)) {
+ local $? = 0;
+ my $kill = kill('KILL', $timer_pid); # We are done, the timer can go.
+ wait();
+ printf "# kill KILL $timer_pid = %d\n", $kill;
+ }
unlink("ktrace.out"); # Used in BSD system call tracing.
print "# All done.\n";
}

File diff suppressed because it is too large Load Diff

View File

@ -1,115 +0,0 @@
constant-1.17
diff -urN perl-5.10.0.orig/lib/constant.pm perl-5.10.0/lib/constant.pm
--- perl-5.10.0.orig/lib/constant.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/constant.pm 2008-10-29 22:38:47.000000000 +0100
@@ -4,7 +4,7 @@
use warnings::register;
use vars qw($VERSION %declared);
-$VERSION = '1.13';
+$VERSION = '1.17';
#=======================================================================
@@ -168,7 +168,7 @@
far less likely to send a space probe to the wrong planet because
nobody noticed the one equation in which you wrote C<3.14195>.
-When a constant is used in an expression, perl replaces it with its
+When a constant is used in an expression, Perl replaces it with its
value at compile time, and may then optimize the expression further.
In particular, any code in an C<if (CONSTANT)> block will be optimized
away if the constant is false.
@@ -331,6 +331,20 @@
(or simply use a comma in place of the big arrow) instead of
C<< CONSTANT => 'value' >>.
+=head1 SEE ALSO
+
+L<Readonly> - Facility for creating read-only scalars, arrays, hashes.
+
+L<Const> - Facility for creating read-only variables. Similar to C<Readonly>,
+but uses C<SvREADONLY> instead of C<tie>.
+
+L<Attribute::Constant> - Make read-only variables via attribute
+
+L<Scalar::Readonly> - Perl extension to the C<SvREADONLY> scalar flag
+
+L<Hash::Util> - A selection of general-utility hash subroutines (mostly
+to lock/unlock keys and values)
+
=head1 BUGS
Please report any bugs or feature requests via the perlbug(1) utility.
@@ -350,7 +364,7 @@
The CPAN distribution is maintained by SE<eacute>bastien Aperghis-Tramoni
E<lt>F<sebastien@aperghis.net>E<gt>.
-=head1 COPYRIGHT
+=head1 COPYRIGHT & LICENSE
Copyright (C) 1997, 1999 Tom Phoenix
diff -urN perl-5.10.0.orig/lib/constant.t perl-5.10.0/lib/constant.t
--- perl-5.10.0.orig/lib/constant.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/constant.t 2008-10-29 22:38:47.000000000 +0100
@@ -12,11 +12,11 @@
BEGIN { # ...and save 'em for later
$SIG{'__WARN__'} = sub { push @warnings, @_ }
}
-END { print STDERR @warnings }
+END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings }
use strict;
-use Test::More tests => 97;
+use Test::More tests => 95;
my $TB = Test::More->builder;
BEGIN { use_ok('constant'); }
@@ -80,13 +80,6 @@
is MESS, q('"'\\"'"\\);
is length(MESS), 8;
-use constant TRAILING => '12 cats';
-{
- local $^W;
- cmp_ok TRAILING, '==', 12;
-}
-is TRAILING, '12 cats';
-
use constant LEADING => " \t1234";
cmp_ok LEADING, '==', 1234;
is LEADING, " \t1234";
@@ -112,7 +105,7 @@
# text may vary, so we can't test much better than this.
cmp_ok length(E2BIG), '>', 6;
-is @warnings, 0 or diag join "\n", "unexpected warning", @warnings;
+is @warnings, 0 or diag join "\n- ", "unexpected warning:", @warnings;
@warnings = (); # just in case
undef &PI;
ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
@@ -122,9 +115,9 @@
is @warnings, 0, "unexpected warning";
my $curr_test = $TB->current_test;
-use constant CSCALAR => \"ok 37\n";
-use constant CHASH => { foo => "ok 38\n" };
-use constant CARRAY => [ undef, "ok 39\n" ];
+use constant CSCALAR => \"ok 35\n";
+use constant CHASH => { foo => "ok 36\n" };
+use constant CARRAY => [ undef, "ok 37\n" ];
use constant CCODE => sub { "ok $_[0]\n" };
my $output = $TB->output ;
@@ -305,7 +298,7 @@
eval 'use constant zit => 4; 1' or die $@;
# empty prototypes are reported differently in different versions
- my $no_proto = $] < 5.008 ? "" : ": none";
+ my $no_proto = $] < 5.008004 ? "" : ": none";
is(scalar @warnings, 1, "1 warning");
like ($warnings[0], qr/^Prototype mismatch: sub main::zit$no_proto vs \(\)/,

View File

@ -7,7 +7,7 @@
Name: perl Name: perl
Version: %{perl_version} Version: %{perl_version}
Release: 112%{?dist} Release: 113%{?dist}
Epoch: %{perl_epoch} Epoch: %{perl_epoch}
Summary: Practical Extraction and Report Language Summary: Practical Extraction and Report Language
Group: Development/Languages Group: Development/Languages
@ -20,9 +20,9 @@ Group: Development/Languages
License: (GPL+ or Artistic) and (GPLv2+ or Artistic) and Copyright Only and MIT and Public Domain and UCD License: (GPL+ or Artistic) and (GPLv2+ or Artistic) and Copyright Only and MIT and Public Domain and UCD
Url: http://www.perl.org/ Url: http://www.perl.org/
Source0: http://www.cpan.org/src/5.0/perl-%{perl_version}.tar.bz2 Source0: http://www.cpan.org/src/5.0/perl-%{perl_version}.tar.bz2
Source11: filter-requires.sh Source1: filter-requires.sh
Source12: perl-5.8.0-libnet.cfg Source2: perl-5.8.0-libnet.cfg
Source13: macros.perl Source3: macros.perl
# Specific to Fedora/RHEL # Specific to Fedora/RHEL
Patch1: perl-suid-noroot.patch Patch1: perl-suid-noroot.patch
@ -101,64 +101,11 @@ Patch203: perl-update-Module-Build.patch
Patch204: perl-update-Parse-CPAN-Meta.patch Patch204: perl-update-Parse-CPAN-Meta.patch
%define Parse_CPAN_Meta_version 1.40 %define Parse_CPAN_Meta_version 1.40
#--- #--- MODULES ---
# FIXME; is 2.18->2.21, should be 2.20->2.21 # Storable_version FIXME; is 2.18->2.21, should be 2.20->2.21
# - was 2.21 previously; but it is not a subpackage, can wait # - was 2.21 previously; but it is not a subpackage, can wait
Patch99: perl-update-Storable.patch # Compress_Raw_Zlib_version FIXME should be 2.023, to preserve upgrade path
%define Storable_version 2.20
# This patches are now unused:
#could be 1.19
Patch100: perl-update-constant.patch
%define constant_version 1.17
# could be 0.36
Patch101: perl-update-Archive-Extract.patch
# could be 1.54
Patch102: perl-update-Archive-Tar.patch
# could be 3.43->3.48
Patch103: perl-update-CGI.patch
# could be 0.22
Patch105: perl-update-File-Fetch.patch
Patch107: perl-update-File-Temp.patch
# could be 0.54
Patch108: perl-update-IPC-Cmd.patch
# could be 2.23
Patch110: perl-update-Module-CoreList.patch
# could be 0.34
Patch111: perl-update-Module-Load-Conditional.patch
# could be 3.10
Patch112: perl-update-Pod-Simple.patch
Patch113: perl-update-Sys-Syslog.patch
%define Sys_Syslog_version 0.27
Patch114: perl-update-Test-Harness.patch
# could be 0.94
Patch115: perl-update-Test-Simple.patch
Patch116: perl-update-Time-HiRes.patch
%define Time_HiRes_version 1.9719
Patch117: perl-update-Digest-SHA.patch
# includes Fatal.pm
Patch118: perl-update-autodie.patch
%define autodie_version 1.999
# cpan has it under PathTools-3.30
# could be 3.31
Patch119: perl-update-FileSpec.patch
%define File_Spec_version 3.30
# FIXME should be 2.023, to preserve upgrade path
# -- for now, we just cheat with the version number # -- for now, we just cheat with the version number
Patch120: perl-update-Compress-Raw-Zlib.patch
%define Compress_Raw_Zlib_version 2.023
# could be 1.22
Patch121: perl-update-Scalar-List-Utils.patch
%define Scalar_List_Utils 1.21
Patch122: perl-update-Module-Pluggable.patch
# could be 2.023
Patch124: perl-update-IO-Compress-Base.patch
%define IO_Compress_Base_version 2.020
# could be 2.023
Patch125: perl-update-IO-Compress-Zlib.patch
%define IO_Compress_Zlib_version 2.020
#... also update version number of Compress::Zlib
# FIXME: Compress-Raw-Zlib also contains Compress-Raw-Bzip2 # FIXME: Compress-Raw-Zlib also contains Compress-Raw-Bzip2
# and IO-Compress-Zlib contains IO-Compress-Bzip2 # and IO-Compress-Zlib contains IO-Compress-Bzip2
@ -168,7 +115,6 @@ Patch125: perl-update-IO-Compress-Zlib.patch
# and also ExtUtils-ParseXS 2.2002 -> 2.21 # and also ExtUtils-ParseXS 2.2002 -> 2.21
BuildRoot: %(mktemp -ud %{_tmppath}/%{name}-%{version}-%{release}-XXXXXX) BuildRoot: %(mktemp -ud %{_tmppath}/%{name}-%{version}-%{release}-XXXXXX)
BuildRequires: tcsh, dos2unix, man, groff BuildRequires: tcsh, dos2unix, man, groff
BuildRequires: gdbm-devel, db4-devel, zlib-devel BuildRequires: gdbm-devel, db4-devel, zlib-devel
@ -255,13 +201,13 @@ Requires(post): perl-libs
# The original script might be /usr/lib/rpm/perl.req or # The original script might be /usr/lib/rpm/perl.req or
# /usr/lib/rpm/redhat/perl.req, better use the original value of the macro: # /usr/lib/rpm/redhat/perl.req, better use the original value of the macro:
%{expand:%%define prev__perl_requires %{__perl_requires}} %{expand:%%define prev__perl_requires %{__perl_requires}}
%define __perl_requires %{SOURCE11} %{prev__perl_requires} %define __perl_requires %{SOURCE1} %{prev__perl_requires}
# When _use_internal_dependency_generator is 0, the perl.req script is # When _use_internal_dependency_generator is 0, the perl.req script is
# called from /usr/lib/rpm{,/redhat}/find-requires.sh # called from /usr/lib/rpm{,/redhat}/find-requires.sh
# Likewise: # Likewise:
%{expand:%%define prev__find_requires %{__find_requires}} %{expand:%%define prev__find_requires %{__find_requires}}
%define __find_requires %{SOURCE11} %{prev__find_requires} %define __find_requires %{SOURCE1} %{prev__find_requires}
%description %description
@ -1101,13 +1047,13 @@ done
# #
# libnet configuration file # libnet configuration file
# #
install -p -m 644 %{SOURCE12} %{build_privlib}/Net/libnet.cfg install -p -m 644 %{SOURCE2} %{build_privlib}/Net/libnet.cfg
# #
# perl RPM macros # perl RPM macros
# #
mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/rpm mkdir -p ${RPM_BUILD_ROOT}%{_sysconfdir}/rpm
install -p -m 644 %{SOURCE13} ${RPM_BUILD_ROOT}%{_sysconfdir}/rpm/ install -p -m 644 %{SOURCE3} ${RPM_BUILD_ROOT}%{_sysconfdir}/rpm/
# #
# Core modules removal # Core modules removal
@ -1825,6 +1771,10 @@ make test
# Old changelog entries are preserved in CVS. # Old changelog entries are preserved in CVS.
%changelog %changelog
* Thu Mar 11 2010 Marcela Mašláňová <mmaslano@redhat.com> - 4:5.10.1-113
- rebuild with new gdbm
- clean spec a little more
* Fri Mar 5 2010 Marcela Mašláňová <mmaslano@redhat.com> - 4:5.10.1-112 * Fri Mar 5 2010 Marcela Mašláňová <mmaslano@redhat.com> - 4:5.10.1-112
- fix license according to advice from legal - fix license according to advice from legal
- clean unused patches - clean unused patches