r25683 - in /branches/upstream/libpar-perl/current: AUTHORS ChangeLog MANIFEST META.yml Makefile.PL SIGNATURE inc/PerlIO.pm inc/Test/Builder.pm inc/Test/Builder/Module.pm inc/Test/More.pm lib/PAR.pm
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Fri Sep 26 21:06:14 UTC 2008
Author: gregoa
Date: Fri Sep 26 21:06:12 2008
New Revision: 25683
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25683
Log:
[svn-upgrade] Integrating new upstream version, libpar-perl (0.983)
Removed:
branches/upstream/libpar-perl/current/SIGNATURE
branches/upstream/libpar-perl/current/inc/PerlIO.pm
Modified:
branches/upstream/libpar-perl/current/AUTHORS
branches/upstream/libpar-perl/current/ChangeLog
branches/upstream/libpar-perl/current/MANIFEST
branches/upstream/libpar-perl/current/META.yml
branches/upstream/libpar-perl/current/Makefile.PL
branches/upstream/libpar-perl/current/inc/Test/Builder.pm
branches/upstream/libpar-perl/current/inc/Test/Builder/Module.pm
branches/upstream/libpar-perl/current/inc/Test/More.pm
branches/upstream/libpar-perl/current/lib/PAR.pm
Modified: branches/upstream/libpar-perl/current/AUTHORS
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/AUTHORS?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/AUTHORS (original)
+++ branches/upstream/libpar-perl/current/AUTHORS Fri Sep 26 21:06:12 2008
@@ -49,6 +49,7 @@
Eric Paulson
Eric Wilhelm
Gaal Yahas (GAAL)
+Gabor Szabo (SZABGAB)
Gerald Richter (GRICHTER)
Germain Garand (GGARAND)
Glenn Mabbutt
Modified: branches/upstream/libpar-perl/current/ChangeLog
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/ChangeLog?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/ChangeLog (original)
+++ branches/upstream/libpar-perl/current/ChangeLog Fri Sep 26 21:06:12 2008
@@ -1,3 +1,20 @@
+[Changes for 0.983 - Sep 12, 2008]
+* Dependencies
+ - Require AutoLoader 5.67 which contains a PAR-related
+ bug-fix.
+ - Require PAR::Dist 0.32.
+
+* Internal changes
+ - The full extraction process _extract_inc
+ (which is triggered when a non--clean pp packaged
+ executable is run) can now be forced to do the
+ extraction (instead of doing if !-d).
+ - That same extraction routine now accepts Archive::Zip
+ handles or file names.
+ - When, during the full extraction, the extracted paths
+ are to be added to @INC, we now make sure they're not
+ in @INC yet.
+
[Changes for 0.982 - Aug 10, 2008]
* New features
- Moved the routines that setup the PAR_TEMP environment variable
Modified: branches/upstream/libpar-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/MANIFEST?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/MANIFEST (original)
+++ branches/upstream/libpar-perl/current/MANIFEST Fri Sep 26 21:06:12 2008
@@ -9,7 +9,6 @@
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
-inc/PerlIO.pm
inc/Test/Builder.pm
inc/Test/Builder/Module.pm
inc/Test/More.pm
@@ -25,7 +24,6 @@
MANIFEST.SKIP
META.yml
README
-SIGNATURE
t/00-pod.t
t/01-basic.t
t/40-par-hashref.t
Modified: branches/upstream/libpar-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/META.yml?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/META.yml (original)
+++ branches/upstream/libpar-perl/current/META.yml Fri Sep 26 21:06:12 2008
@@ -1,33 +1,39 @@
----
-abstract: Perl Archive Tookit
-author:
- - Audrey Tang <cpan at audreyt.org>
+---
+abstract: 'Perl Archive Tookit'
+author:
+ - 'Audrey Tang <cpan at audreyt.org>'
distribution_type: module
-generated_by: Module::Install version 0.68
+generated_by: 'Module::Install version 0.77'
license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
name: PAR
-no_index:
- directory:
+no_index:
+ directory:
- contrib
- inc
- t
-provides:
- PAR:
+provides:
+ PAR:
file: lib/PAR.pm
- version: 0.980
- PAR::Heavy:
+ version: 0.983
+ PAR::Heavy:
file: lib/PAR/Heavy.pm
version: 0.11
-recommends:
+ PAR::SetupProgname:
+ file: lib/PAR/SetupProgname.pm
+ PAR::SetupTemp:
+ file: lib/PAR/SetupTemp.pm
+recommends:
Digest: Module::Signature
-requires:
+requires:
Archive::Zip: 1
- AutoLoader: 5.63
+ AutoLoader: 5.66_02
Compress::Zlib: 1.3
File::Temp: 0.05
- PAR::Dist: 0.22
+ PAR::Dist: 0.32
perl: 5.6.0
-version: 0.980
+resources:
+ license: http://dev.perl.org/licenses/
+version: 0.983
Modified: branches/upstream/libpar-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/Makefile.PL?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/Makefile.PL (original)
+++ branches/upstream/libpar-perl/current/Makefile.PL Fri Sep 26 21:06:12 2008
@@ -9,8 +9,8 @@
requires 'File::Temp' => 0.05;
requires 'Compress::Zlib' => ($^O eq 'MSWin32') ? 1.16 : 1.30;
requires 'Archive::Zip' => 1.00;
-requires 'PAR::Dist' => 0.22;
-requires 'AutoLoader' => 5.63;
+requires 'PAR::Dist' => 0.32;
+requires 'AutoLoader' => '5.66_02';
if (can_use('Crypt::OpenPGP') or can_run('gpg')) {
my $has_sha1 = (
Modified: branches/upstream/libpar-perl/current/inc/Test/Builder.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/inc/Test/Builder.pm?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/inc/Test/Builder.pm (original)
+++ branches/upstream/libpar-perl/current/inc/Test/Builder.pm Fri Sep 26 21:06:12 2008
@@ -1,11 +1,16 @@
#line 1
package Test::Builder;
-use 5.006;
+use 5.004;
+
+# $^C was only introduced in 5.005-ish. We do this to prevent
+# use of uninitialized value warnings in older perls.
+$^C ||= 0;
+
use strict;
-
-our $VERSION = '0.78';
-$VERSION = eval { $VERSION }; # make the alpha version come out as a number
+use vars qw($VERSION);
+$VERSION = '0.74';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
@@ -62,7 +67,7 @@
}
-#line 110
+#line 128
my $Test = Test::Builder->new;
sub new {
@@ -72,7 +77,7 @@
}
-#line 132
+#line 150
sub create {
my $class = shift;
@@ -83,7 +88,7 @@
return $self;
}
-#line 151
+#line 169
use vars qw($Level);
@@ -94,6 +99,7 @@
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
+ $self->{Test_Died} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Original_Pid} = $$;
@@ -112,14 +118,23 @@
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
- $self->{TODO} = undef;
-
$self->_dup_stdhandles unless $^C;
- return;
-}
-
-#line 207
+ return undef;
+}
+
+#line 221
+
+sub exported_to {
+ my($self, $pack) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+#line 243
sub plan {
my($self, $cmd, $arg) = @_;
@@ -158,7 +173,7 @@
return 1;
}
-#line 254
+#line 290
sub expected_tests {
my $self = shift;
@@ -177,7 +192,7 @@
}
-#line 279
+#line 315
sub no_plan {
my $self = shift;
@@ -186,7 +201,7 @@
$self->{Have_Plan} = 1;
}
-#line 294
+#line 330
sub has_plan {
my $self = shift;
@@ -197,7 +212,7 @@
};
-#line 312
+#line 348
sub skip_all {
my($self, $reason) = @_;
@@ -212,19 +227,7 @@
exit(0);
}
-
-#line 339
-
-sub exported_to {
- my($self, $pack) = @_;
-
- if( defined $pack ) {
- $self->{Exported_To} = $pack;
- }
- return $self->{Exported_To};
-}
-
-#line 369
+#line 382
sub ok {
my($self, $test, $name) = @_;
@@ -246,12 +249,9 @@
Very confusing.
ERR
- my $todo = $self->todo();
-
- # Capture the value of $TODO for the rest of this ok() call
- # so it can more easily be found by other routines.
- local $self->{TODO} = $todo;
-
+ my($pack, $file, $line) = $self->caller;
+
+ my $todo = $self->todo($pack);
$self->_unoverload_str(\$todo);
my $out;
@@ -296,14 +296,13 @@
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
- my(undef, $file, $line) = $self->caller;
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file line $line.\n]);
- }
+ if( defined $name ) {
+ $self->diag(qq[ $msg test '$name'\n]);
+ $self->diag(qq[ at $file line $line.\n]);
+ }
+ else {
+ $self->diag(qq[ $msg test at $file line $line.\n]);
+ }
}
return $test ? 1 : 0;
@@ -362,7 +361,7 @@
-#line 521
+#line 530
sub is_eq {
my($self, $got, $expect, $name) = @_;
@@ -419,7 +418,6 @@
}
}
- local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
@@ -427,7 +425,7 @@
}
-#line 600
+#line 608
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
@@ -462,7 +460,7 @@
}
-#line 652
+#line 660
sub like {
my($self, $this, $regex, $name) = @_;
@@ -479,7 +477,7 @@
}
-#line 677
+#line 685
my %numeric_cmps = map { ($_, 1) }
@@ -502,8 +500,7 @@
my $code = $self->_caller_context;
- # Yes, it has to look like this or 5.4.5 won't see the #line
- # directive.
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . "\$got $type \$expect;";
@@ -528,8 +525,6 @@
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
-
- local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
@@ -549,7 +544,7 @@
return $code;
}
-#line 766
+#line 771
sub BAIL_OUT {
my($self, $reason) = @_;
@@ -559,12 +554,12 @@
exit 255;
}
-#line 779
+#line 784
*BAILOUT = \&BAIL_OUT;
-#line 791
+#line 796
sub skip {
my($self, $why) = @_;
@@ -596,7 +591,7 @@
}
-#line 833
+#line 838
sub todo_skip {
my($self, $why) = @_;
@@ -625,7 +620,7 @@
}
-#line 911
+#line 916
sub maybe_regex {
@@ -637,7 +632,7 @@
my($re, $opts);
# Check for qr/foo/
- if( _is_qr($regex) ) {
+ if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
}
# Check for '/foo/' or 'm,foo,'
@@ -649,18 +644,7 @@
}
return $usable_regex;
-}
-
-
-sub _is_qr {
- my $regex = shift;
-
- # is_regexp() checks for regexes in a robust manner, say if they're
- # blessed.
- return re::is_regexp($regex) if defined &re::is_regexp;
- return ref $regex eq 'Regexp';
-}
-
+};
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
@@ -679,8 +663,7 @@
local($@, $!, $SIG{__DIE__}); # isolate eval
- # Yes, it has to look like this or 5.4.5 won't see the #line
- # directive.
+ # Yes, it has to look like this or 5.4.5 won't see the #line directive.
# Don't ask me, man, I just work here.
$test = eval "
$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
@@ -694,8 +677,6 @@
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
-
- local $Level = $Level + 1;
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
@@ -710,7 +691,7 @@
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1009
+#line 1000
sub _try {
my($self, $code) = @_;
@@ -723,7 +704,7 @@
return wantarray ? ($return, $@) : $return;
}
-#line 1031
+#line 1022
sub is_fh {
my $self = shift;
@@ -739,7 +720,7 @@
}
-#line 1076
+#line 1067
sub level {
my($self, $level) = @_;
@@ -751,7 +732,7 @@
}
-#line 1109
+#line 1100
sub use_numbers {
my($self, $use_nums) = @_;
@@ -763,7 +744,7 @@
}
-#line 1143
+#line 1134
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -777,12 +758,12 @@
return $self->{$attribute};
};
- no strict 'refs'; ## no critic
+ no strict 'refs';
*{__PACKAGE__.'::'.$method} = $code;
}
-#line 1197
+#line 1188
sub diag {
my($self, @msgs) = @_;
@@ -809,7 +790,7 @@
return 0;
}
-#line 1234
+#line 1225
sub _print {
my($self, @msgs) = @_;
@@ -833,7 +814,7 @@
print $fh $msg;
}
-#line 1268
+#line 1259
sub _print_diag {
my $self = shift;
@@ -843,7 +824,7 @@
print $fh @_;
}
-#line 1305
+#line 1296
sub output {
my($self, $fh) = @_;
@@ -882,9 +863,10 @@
$fh = $file_or_fh;
}
else {
- open $fh, ">", $file_or_fh or
+ $fh = do { local *FH };
+ open $fh, ">$file_or_fh" or
$self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
+ _autoflush($fh);
}
return $fh;
@@ -899,7 +881,6 @@
}
-my($Testout, $Testerr);
sub _dup_stdhandles {
my $self = shift;
@@ -907,47 +888,29 @@
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
- _autoflush($Testout);
+ _autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
- _autoflush($Testerr);
+ _autoflush(\*TESTERR);
_autoflush(\*STDERR);
- $self->output ($Testout);
- $self->failure_output($Testerr);
- $self->todo_output ($Testout);
+ $self->output(\*TESTOUT);
+ $self->failure_output(\*TESTERR);
+ $self->todo_output(\*TESTOUT);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
- my $self = shift;
-
return if $Opened_Testhandles;
-
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
- open( $Testout, ">&STDOUT") or die "Can't dup STDOUT: $!";
- open( $Testerr, ">&STDERR") or die "Can't dup STDERR: $!";
-
-# $self->_copy_io_layers( \*STDOUT, $Testout );
-# $self->_copy_io_layers( \*STDERR, $Testerr );
-
+ open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
+ open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
$Opened_Testhandles = 1;
}
-sub _copy_io_layers {
- my($self, $src, $dest) = @_;
-
- $self->_try(sub {
- require PerlIO;
- my @layers = PerlIO::get_layers($src);
-
- binmode $dest, join " ", map ":$_", @layers if @layers;
- });
-}
-
-#line 1423
+#line 1396
sub _message_at_caller {
my $self = shift;
@@ -976,7 +939,7 @@
}
}
-#line 1471
+#line 1444
sub current_test {
my($self, $num) = @_;
@@ -1012,7 +975,7 @@
}
-#line 1516
+#line 1489
sub summary {
my($self) = shift;
@@ -1020,29 +983,27 @@
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 1571
+#line 1544
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 1597
+#line 1569
sub todo {
my($self, $pack) = @_;
- return $self->{TODO} if defined $self->{TODO};
-
- $pack = $pack || $self->caller(1) || $self->exported_to;
+ $pack = $pack || $self->exported_to || $self->caller($Level);
return 0 unless $pack;
- no strict 'refs'; ## no critic
+ no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
-#line 1622
+#line 1590
sub caller {
my($self, $height) = @_;
@@ -1052,9 +1013,9 @@
return wantarray ? @caller : $caller[0];
}
-#line 1634
-
-#line 1648
+#line 1602
+
+#line 1616
#'#
sub _sanity_check {
@@ -1067,7 +1028,7 @@
'Somehow you got a different number of results than tests ran!');
}
-#line 1669
+#line 1637
sub _whoa {
my($self, $check, $desc) = @_;
@@ -1080,7 +1041,7 @@
}
}
-#line 1691
+#line 1659
sub _my_exit {
$? = $_[0];
@@ -1089,29 +1050,37 @@
}
-#line 1704
+#line 1672
+
+$SIG{__DIE__} = sub {
+ # We don't want to muck with death in an eval, but $^S isn't
+ # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
+ # with it. Instead, we use caller. This also means it runs under
+ # 5.004!
+ my $in_eval = 0;
+ for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
+ $in_eval = 1 if $sub =~ /^\(eval\)/;
+ }
+ $Test->{Test_Died} = 1 unless $in_eval;
+};
sub _ending {
my $self = shift;
- my $real_exit_code = $?;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
- if( $self->{Original_Pid} != $$ ) {
- return;
- }
-
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
- if( !$self->{Have_Plan} ) {
- return;
- }
-
# Don't do an ending if we bailed out.
- if( $self->{Bailed_Out} ) {
- return;
+ if( ($self->{Original_Pid} != $$) or
+ (!$self->{Have_Plan} && !$self->{Test_Died}) or
+ $self->{Bailed_Out}
+ )
+ {
+ _my_exit($?);
+ return;
}
# Figure out if we passed or failed and print helpful messages.
@@ -1161,7 +1130,7 @@
FAIL
}
- if( $real_exit_code ) {
+ if( $self->{Test_Died} ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
@@ -1185,7 +1154,7 @@
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
- elsif ( $real_exit_code ) {
+ elsif ( $self->{Test_Died} ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
@@ -1201,6 +1170,6 @@
$Test->_ending if defined $Test and !$Test->no_ending;
}
-#line 1871
+#line 1847
1;
Modified: branches/upstream/libpar-perl/current/inc/Test/Builder/Module.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/inc/Test/Builder/Module.pm?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/inc/Test/Builder/Module.pm (original)
+++ branches/upstream/libpar-perl/current/inc/Test/Builder/Module.pm Fri Sep 26 21:06:12 2008
@@ -1,14 +1,14 @@
#line 1
package Test::Builder::Module;
-
-use strict;
use Test::Builder;
require Exporter;
-our @ISA = qw(Exporter);
+ at ISA = qw(Exporter);
-our $VERSION = '0.78';
+$VERSION = '0.74';
+
+use strict;
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
@@ -24,9 +24,6 @@
sub import {
my($class) = shift;
-
- # Don't run all this when loading ourself.
- return 1 if $class eq 'Test::Builder::Module';
my $test = $class->builder;
@@ -70,12 +67,12 @@
}
-#line 147
+#line 144
sub import_extra {}
-#line 178
+#line 175
sub builder {
return Test::Builder->new;
Modified: branches/upstream/libpar-perl/current/inc/Test/More.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/inc/Test/More.pm?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/inc/Test/More.pm (original)
+++ branches/upstream/libpar-perl/current/inc/Test/More.pm Fri Sep 26 21:06:12 2008
@@ -1,7 +1,8 @@
#line 1
package Test::More;
-use 5.006;
+use 5.004;
+
use strict;
@@ -16,7 +17,7 @@
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.78';
+$VERSION = '0.74';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@@ -31,11 +32,11 @@
plan
can_ok isa_ok
diag
- BAIL_OUT
+ BAIL_OUT
);
-#line 156
+#line 157
sub plan {
my $tb = Test::More->builder;
@@ -69,7 +70,7 @@
}
-#line 256
+#line 257
sub ok ($;$) {
my($test, $name) = @_;
@@ -78,7 +79,7 @@
$tb->ok($test, $name);
}
-#line 323
+#line 324
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -95,7 +96,7 @@
*isn't = \&isnt;
-#line 368
+#line 369
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -104,7 +105,7 @@
}
-#line 384
+#line 385
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -113,7 +114,7 @@
}
-#line 424
+#line 425
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -122,7 +123,7 @@
}
-#line 460
+#line 461
sub can_ok ($@) {
my($proto, @methods) = @_;
@@ -157,7 +158,7 @@
return $ok;
}
-#line 522
+#line 523
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
@@ -211,7 +212,7 @@
}
-#line 591
+#line 592
sub pass (;$) {
my $tb = Test::More->builder;
@@ -223,7 +224,7 @@
$tb->ok(0, @_);
}
-#line 652
+#line 653
sub use_ok ($;@) {
my($module, @imports) = @_;
@@ -232,28 +233,30 @@
my($pack,$filename,$line) = caller;
- my $code;
- if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
- # probably a version check. Perl needs to see the bare number
- # for it to work with non-Exporter based modules.
- $code = <<USE;
+ # Work around a glitch in $@ and eval
+ my $eval_error;
+ {
+ local($@,$!,$SIG{__DIE__}); # isolate eval
+
+ if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
+ # probably a version check. Perl needs to see the bare number
+ # for it to work with non-Exporter based modules.
+ eval <<USE;
package $pack;
use $module $imports[0];
-1;
USE
- }
- else {
- $code = <<USE;
+ }
+ else {
+ eval <<USE;
package $pack;
-use $module \@{\$args[0]};
-1;
+use $module \@imports;
USE
- }
-
-
- my($eval_result, $eval_error) = _eval($code, \@imports);
- my $ok = $tb->ok( $eval_result, "use $module;" );
-
+ }
+ $eval_error = $@;
+ }
+
+ my $ok = $tb->ok( !$eval_error, "use $module;" );
+
unless( $ok ) {
chomp $eval_error;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
@@ -268,21 +271,7 @@
return $ok;
}
-
-sub _eval {
- my($code) = shift;
- my @args = @_;
-
- # Work around oddities surrounding resetting of $@ by immediately
- # storing it.
- local($@,$!,$SIG{__DIE__}); # isolate eval
- my $eval_result = eval $code;
- my $eval_error = $@;
-
- return($eval_result, $eval_error);
-}
-
-#line 718
+#line 707
sub require_ok ($) {
my($module) = shift;
@@ -294,20 +283,20 @@
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
- my $code = <<REQUIRE;
+ local($!, $@, $SIG{__DIE__}); # isolate eval
+ local $SIG{__DIE__};
+ eval <<REQUIRE;
package $pack;
require $module;
-1;
REQUIRE
- my($eval_result, $eval_error) = _eval($code);
- my $ok = $tb->ok( $eval_result, "require $module;" );
+ my $ok = $tb->ok( !$@, "require $module;" );
unless( $ok ) {
- chomp $eval_error;
+ chomp $@;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
- Error: $eval_error
+ Error: $@
DIAGNOSTIC
}
@@ -326,7 +315,7 @@
$module =~ /^[a-zA-Z]\w*$/;
}
-#line 795
+#line 784
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
@@ -433,7 +422,7 @@
return '';
}
-#line 941
+#line 930
sub diag {
my $tb = Test::More->builder;
@@ -442,7 +431,7 @@
}
-#line 1010
+#line 999
#'#
sub skip {
@@ -470,7 +459,7 @@
}
-#line 1097
+#line 1086
sub todo_skip {
my($why, $how_many) = @_;
@@ -491,7 +480,7 @@
last TODO;
}
-#line 1150
+#line 1139
sub BAIL_OUT {
my $reason = shift;
@@ -500,7 +489,7 @@
$tb->BAIL_OUT($reason);
}
-#line 1189
+#line 1178
#'#
sub eq_array {
@@ -624,7 +613,7 @@
}
-#line 1320
+#line 1309
sub eq_hash {
local @Data_Stack;
@@ -657,7 +646,7 @@
return $ok;
}
-#line 1377
+#line 1366
sub eq_set {
my($a1, $a2) = @_;
@@ -683,6 +672,6 @@
);
}
-#line 1567
+#line 1556
1;
Modified: branches/upstream/libpar-perl/current/lib/PAR.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libpar-perl/current/lib/PAR.pm?rev=25683&op=diff
==============================================================================
--- branches/upstream/libpar-perl/current/lib/PAR.pm (original)
+++ branches/upstream/libpar-perl/current/lib/PAR.pm Fri Sep 26 21:06:12 2008
@@ -1,5 +1,5 @@
package PAR;
-$PAR::VERSION = '0.982';
+$PAR::VERSION = '0.983';
use 5.006;
use strict;
@@ -35,7 +35,7 @@
=head1 VERSION
-This document describes release 0.982 of PAR, released August 10, 2008.
+This document describes release 0.983 of PAR, released September 12, 2008.
=head1 SYNOPSIS
@@ -583,39 +583,63 @@
}
}
+# extract the contents of a .par (or .exe) or any
+# Archive::Zip handle to the PAR_TEMP/inc directory.
+# returns that directory.
sub _extract_inc {
- my $file = shift;
+ my $file_or_azip_handle = shift;
+ my $force_extract = shift;
my $inc = "$PAR::SetupTemp::PARTemp/inc";
my $dlext = defined($Config{dlext}) ? $Config::Config{dlext} : '';
-
- if (!-d $inc) {
+ my $inc_exists = -d $inc;
+ my $is_handle = ref($file_or_azip_handle) && $file_or_azip_handle->isa('Archive::Zip::Archive');
+
+ require File::Spec;
+
+ if (!$inc_exists or $force_extract) {
for (1 .. 10) { mkdir("$inc.lock", 0755) and last; sleep 1 }
- # First try to unzip the *fast* way.
- eval {
- require Archive::Unzip::Burst;
- Archive::Unzip::Burst::unzip($file, $inc)
- and die "Could not unzip '$file' into '$inc'. Error: $!";
- };
-
- # This means the fast module is there, but didn't work.
- if ($@ =~ /^Could not unzip/) {
- die $@;
- }
-
- # failed to load Archive::Unzip::Burst. Default to slow way.
- elsif ($@) {
- open my $fh, '<', $file or die "Cannot find '$file': $!";
- binmode($fh);
- bless($fh, 'IO::File');
-
- my $zip = Archive::Zip->new;
- ( $zip->readFromFileHandle($fh, $file) == Archive::Zip::AZ_OK() )
- or die "Read '$file' error: $!";
+ undef $@;
+ if (!$is_handle) {
+ # First try to unzip the *fast* way.
+ eval {
+ require Archive::Unzip::Burst;
+ Archive::Unzip::Burst::unzip($file_or_azip_handle, $inc)
+ and die "Could not unzip '$file_or_azip_handle' into '$inc'. Error: $!";
+ die;
+ };
+
+ # This means the fast module is there, but didn't work.
+ if ($@ =~ /^Could not unzip/) {
+ die $@;
+ }
+ }
+
+ # either failed to load Archive::Unzip::Burst or got an A::Zip handle
+ # fallback to slow way.
+ if ($is_handle || $@) {
+ my $zip;
+ if (!$is_handle) {
+ open my $fh, '<', $file_or_azip_handle
+ or die "Cannot find '$file_or_azip_handle': $!";
+ binmode($fh);
+ bless($fh, 'IO::File');
+
+ $zip = Archive::Zip->new;
+ ( $zip->readFromFileHandle($fh, $file_or_azip_handle) == Archive::Zip::AZ_OK() )
+ or die "Read '$file_or_azip_handle' error: $!";
+ }
+ else {
+ $zip = $file_or_azip_handle;
+ }
+
+ mkdir($inc) if not -d $inc;
for ( $zip->memberNames() ) {
next if m{\.\Q$dlext\E[^/]*$};
s{^/}{};
+ my $outfile = File::Spec->catfile($inc, $_);
+ next if -e $outfile and not -w _;
$zip->extractMember($_, "$inc/" . $_);
}
}
@@ -623,9 +647,16 @@
rmdir("$inc.lock");
}
- require File::Spec;
- unshift @INC, grep -d, map File::Spec->catdir($inc, @$_),
- [ 'lib' ], [ 'arch' ], [ $arch ], [ $ver ], [ $ver, $arch ], [];
+ # add the freshly extracted directories to @INC,
+ # but make sure there's no duplicates
+ my %inc_exists = map { ($_, 1) } @INC;
+ unshift @INC, grep !exists($inc_exists{$_}),
+ grep -d,
+ map File::Spec->catdir($inc, @$_),
+ [ 'lib' ], [ 'arch' ], [ $arch ],
+ [ $ver ], [ $ver, $arch ], [];
+
+ return $inc;
}
More information about the Pkg-perl-cvs-commits
mailing list