r22694 - in /branches/upstream/libscalar-defer-perl/current: Changes MANIFEST META.yml SIGNATURE inc/PerlIO.pm inc/Test/Builder.pm inc/Test/Builder/Module.pm inc/Test/More.pm lib/Scalar/Defer.pm
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Wed Jul 2 21:58:40 UTC 2008
Author: gregoa
Date: Wed Jul 2 21:58:40 2008
New Revision: 22694
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=22694
Log:
[svn-upgrade] Integrating new upstream version, libscalar-defer-perl (0.16)
Added:
branches/upstream/libscalar-defer-perl/current/inc/PerlIO.pm
Modified:
branches/upstream/libscalar-defer-perl/current/Changes
branches/upstream/libscalar-defer-perl/current/MANIFEST
branches/upstream/libscalar-defer-perl/current/META.yml
branches/upstream/libscalar-defer-perl/current/SIGNATURE
branches/upstream/libscalar-defer-perl/current/inc/Test/Builder.pm
branches/upstream/libscalar-defer-perl/current/inc/Test/Builder/Module.pm
branches/upstream/libscalar-defer-perl/current/inc/Test/More.pm
branches/upstream/libscalar-defer-perl/current/lib/Scalar/Defer.pm
Modified: branches/upstream/libscalar-defer-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/Changes?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/Changes (original)
+++ branches/upstream/libscalar-defer-perl/current/Changes Wed Jul 2 21:58:40 2008
@@ -1,3 +1,8 @@
+[Changes for 0.16 - 2008-07-01]
+
+* The previous version would clobber @ARGV when used with
+ UNIVERSAL::require. Sorry.
+
[Changes for 0.15 - 2008-06-27]
* Fix infinite recursion on UNIVERSAL methods used as class methods on
Modified: branches/upstream/libscalar-defer-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/MANIFEST?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/MANIFEST (original)
+++ branches/upstream/libscalar-defer-perl/current/MANIFEST Wed Jul 2 21:58:40 2008
@@ -11,6 +11,7 @@
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
inc/ok.pm
+inc/PerlIO.pm
inc/Test/Builder.pm
inc/Test/Builder/Module.pm
inc/Test/More.pm
Modified: branches/upstream/libscalar-defer-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/META.yml?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/META.yml (original)
+++ branches/upstream/libscalar-defer-perl/current/META.yml Wed Jul 2 21:58:40 2008
@@ -16,11 +16,11 @@
provides:
Scalar::Defer:
file: lib/Scalar/Defer.pm
- version: 0.15
+ version: 0.16
Scalar::Defer::Deferred:
file: lib/Scalar/Defer.pm
requires:
Class::InsideOut: 0
Exporter::Lite: 0
perl: 5.6.0
-version: 0.15
+version: 0.16
Modified: branches/upstream/libscalar-defer-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/SIGNATURE?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/SIGNATURE (original)
+++ branches/upstream/libscalar-defer-perl/current/SIGNATURE Wed Jul 2 21:58:40 2008
@@ -14,9 +14,9 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 fecb756fba00cbb410b9e1fdbc77428d02c21e3a Changes
-SHA1 87264922034d0f62430c0b54b72f67a7eec55305 MANIFEST
-SHA1 795a01606557ef5a5a9b9b4e12960e734f0069b0 META.yml
+SHA1 1f930f695539b8078a262361405ef665c0ec2b3b Changes
+SHA1 1bb29d8c39fd2879e6b3daf1e772807a089abca8 MANIFEST
+SHA1 3c4ee012a911115133771a6614123dfaedcb589a META.yml
SHA1 91868dc8231c258af600393393c7fb0362935e85 Makefile.PL
SHA1 91735f73073ea3d7b2d64047e45d25355f516752 README
SHA1 603bb9de29fb8cba7f13409c546750972eff645d inc/Module/AutoInstall.pm
@@ -30,17 +30,18 @@
SHA1 7d3be9b158e37b2b2c22084740099955623b1d56 inc/Module/Install/Metadata.pm
SHA1 0a8b66180229ba2f9deaea1fedd0aacf7a7ace6b inc/Module/Install/Win32.pm
SHA1 d3352eb33fe43a5f3ead513f645224fe34d73bc9 inc/Module/Install/WriteAll.pm
-SHA1 98cd56704e09b57d9ba121b45d976c3d09a9f19c inc/Test/Builder.pm
-SHA1 6e95f0ebeb31abc5608a987e88edf2e2427912c4 inc/Test/Builder/Module.pm
-SHA1 1296aa4ac787d6df9f9679d2bae4851ffef63e5a inc/Test/More.pm
+SHA1 fb1a897882981885fb57a77fba9bdc588053fc2a inc/PerlIO.pm
+SHA1 277a6e23761120cf71b7f77377e9770ce8df01e5 inc/Test/Builder.pm
+SHA1 e7b7c09a0f71c2ddf5f08ccc859f75acf5df751a inc/Test/Builder/Module.pm
+SHA1 643f63b9d5ab3326cf2421436ca1f56f63ddc3ce inc/Test/More.pm
SHA1 55be398173a2d979a648a73a28c8b3a40531dbba inc/ok.pm
-SHA1 b667e77f08dfff82d02ab46b82fe7a1909c4e891 lib/Scalar/Defer.pm
+SHA1 017dc1a7278a2fabe45d36681e7638cf77b5f62d lib/Scalar/Defer.pm
SHA1 f89e83f7a812e3b8c6afe96bb087d0b8218cbd04 t/01-basic.t
SHA1 2be303573646cd1aee91665c353bce5cb0efd349 t/02-is.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.3 (Darwin)
-iD8DBQFIZQ+itLPdNzw1AaARAteFAJ9yPqpLExwQi6kuuj2R81DpAeqtEQCgs921
-aaAEaTdZexNhXS7ZuVuOuGQ=
-=SjXY
+iD8DBQFIaj54tLPdNzw1AaARAo5sAJ0XqU4ndhGx+TVJk4iR+9Vtiyy9eACgpq2C
+RZDRHyFz9rB6TKo4Dg/oYQk=
+=E57u
-----END PGP SIGNATURE-----
Added: branches/upstream/libscalar-defer-perl/current/inc/PerlIO.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/inc/PerlIO.pm?rev=22694&op=file
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/inc/PerlIO.pm (added)
+++ branches/upstream/libscalar-defer-perl/current/inc/PerlIO.pm Wed Jul 2 21:58:40 2008
@@ -1,0 +1,33 @@
+#line 1
+package PerlIO;
+
+our $VERSION = '1.04';
+
+# Map layer name to package that defines it
+our %alias;
+
+sub import
+{
+ my $class = shift;
+ while (@_)
+ {
+ my $layer = shift;
+ if (exists $alias{$layer})
+ {
+ $layer = $alias{$layer}
+ }
+ else
+ {
+ $layer = "${class}::$layer";
+ }
+ eval "require $layer";
+ warn $@ if $@;
+ }
+}
+
+sub F_UTF8 () { 0x8000 }
+
+1;
+__END__
+
+#line 344
Modified: branches/upstream/libscalar-defer-perl/current/inc/Test/Builder.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/inc/Test/Builder.pm?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/inc/Test/Builder.pm (original)
+++ branches/upstream/libscalar-defer-perl/current/inc/Test/Builder.pm Wed Jul 2 21:58:40 2008
@@ -1,16 +1,11 @@
#line 1
package Test::Builder;
-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 5.006;
use strict;
-use vars qw($VERSION);
-$VERSION = '0.74';
-$VERSION = eval $VERSION; # make the alpha version come out as a number
+
+our $VERSION = '0.80';
+$VERSION = eval { $VERSION }; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
BEGIN {
@@ -67,7 +62,7 @@
}
-#line 128
+#line 110
my $Test = Test::Builder->new;
sub new {
@@ -77,7 +72,7 @@
}
-#line 150
+#line 132
sub create {
my $class = shift;
@@ -88,7 +83,7 @@
return $self;
}
-#line 169
+#line 151
use vars qw($Level);
@@ -99,7 +94,6 @@
# 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} = $$;
@@ -118,23 +112,14 @@
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
+ $self->{TODO} = undef;
+
$self->_dup_stdhandles unless $^C;
- return undef;
-}
-
-#line 221
-
-sub exported_to {
- my($self, $pack) = @_;
-
- if( defined $pack ) {
- $self->{Exported_To} = $pack;
- }
- return $self->{Exported_To};
-}
-
-#line 243
+ return;
+}
+
+#line 207
sub plan {
my($self, $cmd, $arg) = @_;
@@ -173,7 +158,7 @@
return 1;
}
-#line 290
+#line 254
sub expected_tests {
my $self = shift;
@@ -192,7 +177,7 @@
}
-#line 315
+#line 279
sub no_plan {
my $self = shift;
@@ -201,7 +186,7 @@
$self->{Have_Plan} = 1;
}
-#line 330
+#line 294
sub has_plan {
my $self = shift;
@@ -212,7 +197,7 @@
};
-#line 348
+#line 312
sub skip_all {
my($self, $reason) = @_;
@@ -227,7 +212,19 @@
exit(0);
}
-#line 382
+
+#line 339
+
+sub exported_to {
+ my($self, $pack) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+#line 369
sub ok {
my($self, $test, $name) = @_;
@@ -249,9 +246,12 @@
Very confusing.
ERR
- my($pack, $file, $line) = $self->caller;
-
- my $todo = $self->todo($pack);
+ 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;
+
$self->_unoverload_str(\$todo);
my $out;
@@ -296,13 +296,14 @@
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
- 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]);
- }
+ 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]);
+ }
}
return $test ? 1 : 0;
@@ -361,7 +362,7 @@
-#line 530
+#line 521
sub is_eq {
my($self, $got, $expect, $name) = @_;
@@ -418,6 +419,7 @@
}
}
+ local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
@@ -425,7 +427,7 @@
}
-#line 608
+#line 600
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
@@ -460,7 +462,7 @@
}
-#line 660
+#line 652
sub like {
my($self, $this, $regex, $name) = @_;
@@ -477,7 +479,7 @@
}
-#line 685
+#line 677
my %numeric_cmps = map { ($_, 1) }
@@ -500,7 +502,8 @@
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;";
@@ -525,6 +528,8 @@
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
@@ -544,7 +549,7 @@
return $code;
}
-#line 771
+#line 766
sub BAIL_OUT {
my($self, $reason) = @_;
@@ -554,12 +559,12 @@
exit 255;
}
-#line 784
+#line 779
*BAILOUT = \&BAIL_OUT;
-#line 796
+#line 791
sub skip {
my($self, $why) = @_;
@@ -591,7 +596,7 @@
}
-#line 838
+#line 833
sub todo_skip {
my($self, $why) = @_;
@@ -620,7 +625,7 @@
}
-#line 916
+#line 911
sub maybe_regex {
@@ -632,7 +637,7 @@
my($re, $opts);
# Check for qr/foo/
- if( ref $regex eq 'Regexp' ) {
+ if( _is_qr($regex) ) {
$usable_regex = $regex;
}
# Check for '/foo/' or 'm,foo,'
@@ -644,7 +649,18 @@
}
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) = @_;
@@ -663,7 +679,8 @@
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};
@@ -677,6 +694,8 @@
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'
@@ -691,7 +710,7 @@
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1000
+#line 1009
sub _try {
my($self, $code) = @_;
@@ -704,7 +723,7 @@
return wantarray ? ($return, $@) : $return;
}
-#line 1022
+#line 1031
sub is_fh {
my $self = shift;
@@ -720,7 +739,7 @@
}
-#line 1067
+#line 1076
sub level {
my($self, $level) = @_;
@@ -732,7 +751,7 @@
}
-#line 1100
+#line 1109
sub use_numbers {
my($self, $use_nums) = @_;
@@ -744,7 +763,7 @@
}
-#line 1134
+#line 1143
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -758,12 +777,12 @@
return $self->{$attribute};
};
- no strict 'refs';
+ no strict 'refs'; ## no critic
*{__PACKAGE__.'::'.$method} = $code;
}
-#line 1188
+#line 1197
sub diag {
my($self, @msgs) = @_;
@@ -790,7 +809,7 @@
return 0;
}
-#line 1225
+#line 1234
sub _print {
my($self, @msgs) = @_;
@@ -814,7 +833,7 @@
print $fh $msg;
}
-#line 1259
+#line 1268
sub _print_diag {
my $self = shift;
@@ -824,7 +843,7 @@
print $fh @_;
}
-#line 1296
+#line 1305
sub output {
my($self, $fh) = @_;
@@ -863,10 +882,9 @@
$fh = $file_or_fh;
}
else {
- $fh = do { local *FH };
- open $fh, ">$file_or_fh" or
+ open $fh, ">", $file_or_fh or
$self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
+ _autoflush($fh);
}
return $fh;
@@ -881,6 +899,7 @@
}
+my($Testout, $Testerr);
sub _dup_stdhandles {
my $self = shift;
@@ -888,29 +907,47 @@
# 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: $!";
+ 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 );
+
$Opened_Testhandles = 1;
}
-#line 1396
+sub _copy_io_layers {
+ my($self, $src, $dst) = @_;
+
+ $self->_try(sub {
+ require PerlIO;
+ my @src_layers = PerlIO::get_layers($src);
+
+ binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
+ });
+}
+
+#line 1423
sub _message_at_caller {
my $self = shift;
@@ -939,7 +976,7 @@
}
}
-#line 1444
+#line 1471
sub current_test {
my($self, $num) = @_;
@@ -975,7 +1012,7 @@
}
-#line 1489
+#line 1516
sub summary {
my($self) = shift;
@@ -983,27 +1020,29 @@
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 1544
+#line 1571
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 1569
+#line 1597
sub todo {
my($self, $pack) = @_;
- $pack = $pack || $self->exported_to || $self->caller($Level);
+ return $self->{TODO} if defined $self->{TODO};
+
+ $pack = $pack || $self->caller(1) || $self->exported_to;
return 0 unless $pack;
- no strict 'refs';
+ no strict 'refs'; ## no critic
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
-#line 1590
+#line 1622
sub caller {
my($self, $height) = @_;
@@ -1013,9 +1052,9 @@
return wantarray ? @caller : $caller[0];
}
-#line 1602
-
-#line 1616
+#line 1634
+
+#line 1648
#'#
sub _sanity_check {
@@ -1028,7 +1067,7 @@
'Somehow you got a different number of results than tests ran!');
}
-#line 1637
+#line 1669
sub _whoa {
my($self, $check, $desc) = @_;
@@ -1041,7 +1080,7 @@
}
}
-#line 1659
+#line 1691
sub _my_exit {
$? = $_[0];
@@ -1050,37 +1089,29 @@
}
-#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;
-};
+#line 1704
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->{Original_Pid} != $$) or
- (!$self->{Have_Plan} && !$self->{Test_Died}) or
- $self->{Bailed_Out}
- )
- {
- _my_exit($?);
- return;
+ if( $self->{Bailed_Out} ) {
+ return;
}
# Figure out if we passed or failed and print helpful messages.
@@ -1130,7 +1161,7 @@
FAIL
}
- if( $self->{Test_Died} ) {
+ if( $real_exit_code ) {
$self->diag(<<"FAIL");
Looks like your test died just after $self->{Curr_Test}.
FAIL
@@ -1154,7 +1185,7 @@
elsif ( $self->{Skip_All} ) {
_my_exit( 0 ) && return;
}
- elsif ( $self->{Test_Died} ) {
+ elsif ( $real_exit_code ) {
$self->diag(<<'FAIL');
Looks like your test died before it could output anything.
FAIL
@@ -1170,6 +1201,6 @@
$Test->_ending if defined $Test and !$Test->no_ending;
}
-#line 1847
+#line 1871
1;
Modified: branches/upstream/libscalar-defer-perl/current/inc/Test/Builder/Module.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/inc/Test/Builder/Module.pm?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/inc/Test/Builder/Module.pm (original)
+++ branches/upstream/libscalar-defer-perl/current/inc/Test/Builder/Module.pm Wed Jul 2 21:58:40 2008
@@ -1,14 +1,14 @@
#line 1
package Test::Builder::Module;
+
+use strict;
use Test::Builder;
require Exporter;
- at ISA = qw(Exporter);
+our @ISA = qw(Exporter);
-$VERSION = '0.74';
-
-use strict;
+our $VERSION = '0.80';
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
@@ -24,6 +24,9 @@
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;
@@ -67,12 +70,12 @@
}
-#line 144
+#line 147
sub import_extra {}
-#line 175
+#line 178
sub builder {
return Test::Builder->new;
Modified: branches/upstream/libscalar-defer-perl/current/inc/Test/More.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/inc/Test/More.pm?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/inc/Test/More.pm (original)
+++ branches/upstream/libscalar-defer-perl/current/inc/Test/More.pm Wed Jul 2 21:58:40 2008
@@ -1,8 +1,7 @@
#line 1
package Test::More;
-use 5.004;
-
+use 5.006;
use strict;
@@ -17,7 +16,7 @@
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.74';
+$VERSION = '0.80';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@@ -32,11 +31,11 @@
plan
can_ok isa_ok
diag
- BAIL_OUT
+ BAIL_OUT
);
-#line 157
+#line 156
sub plan {
my $tb = Test::More->builder;
@@ -70,7 +69,7 @@
}
-#line 257
+#line 256
sub ok ($;$) {
my($test, $name) = @_;
@@ -79,7 +78,7 @@
$tb->ok($test, $name);
}
-#line 324
+#line 323
sub is ($$;$) {
my $tb = Test::More->builder;
@@ -96,7 +95,7 @@
*isn't = \&isnt;
-#line 369
+#line 368
sub like ($$;$) {
my $tb = Test::More->builder;
@@ -105,7 +104,7 @@
}
-#line 385
+#line 384
sub unlike ($$;$) {
my $tb = Test::More->builder;
@@ -114,7 +113,7 @@
}
-#line 425
+#line 424
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
@@ -123,7 +122,7 @@
}
-#line 461
+#line 460
sub can_ok ($@) {
my($proto, @methods) = @_;
@@ -158,7 +157,7 @@
return $ok;
}
-#line 523
+#line 522
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
@@ -212,7 +211,7 @@
}
-#line 592
+#line 591
sub pass (;$) {
my $tb = Test::More->builder;
@@ -224,7 +223,7 @@
$tb->ok(0, @_);
}
-#line 653
+#line 652
sub use_ok ($;@) {
my($module, @imports) = @_;
@@ -233,30 +232,28 @@
my($pack,$filename,$line) = caller;
- # 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;
+ 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;
package $pack;
use $module $imports[0];
+1;
USE
- }
- else {
- eval <<USE;
+ }
+ else {
+ $code = <<USE;
package $pack;
-use $module \@imports;
+use $module \@{\$args[0]};
+1;
USE
- }
- $eval_error = $@;
- }
-
- my $ok = $tb->ok( !$eval_error, "use $module;" );
-
+ }
+
+
+ my($eval_result, $eval_error) = _eval($code, \@imports);
+ my $ok = $tb->ok( $eval_result, "use $module;" );
+
unless( $ok ) {
chomp $eval_error;
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
@@ -271,7 +268,21 @@
return $ok;
}
-#line 707
+
+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
sub require_ok ($) {
my($module) = shift;
@@ -283,20 +294,20 @@
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
- local($!, $@, $SIG{__DIE__}); # isolate eval
- local $SIG{__DIE__};
- eval <<REQUIRE;
+ my $code = <<REQUIRE;
package $pack;
require $module;
+1;
REQUIRE
- my $ok = $tb->ok( !$@, "require $module;" );
+ my($eval_result, $eval_error) = _eval($code);
+ my $ok = $tb->ok( $eval_result, "require $module;" );
unless( $ok ) {
- chomp $@;
+ chomp $eval_error;
$tb->diag(<<DIAGNOSTIC);
Tried to require '$module'.
- Error: $@
+ Error: $eval_error
DIAGNOSTIC
}
@@ -315,7 +326,7 @@
$module =~ /^[a-zA-Z]\w*$/;
}
-#line 784
+#line 795
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
@@ -422,7 +433,7 @@
return '';
}
-#line 930
+#line 941
sub diag {
my $tb = Test::More->builder;
@@ -431,7 +442,7 @@
}
-#line 999
+#line 1010
#'#
sub skip {
@@ -459,7 +470,7 @@
}
-#line 1086
+#line 1097
sub todo_skip {
my($why, $how_many) = @_;
@@ -480,7 +491,7 @@
last TODO;
}
-#line 1139
+#line 1150
sub BAIL_OUT {
my $reason = shift;
@@ -489,7 +500,7 @@
$tb->BAIL_OUT($reason);
}
-#line 1178
+#line 1189
#'#
sub eq_array {
@@ -613,7 +624,7 @@
}
-#line 1309
+#line 1320
sub eq_hash {
local @Data_Stack;
@@ -646,7 +657,7 @@
return $ok;
}
-#line 1366
+#line 1377
sub eq_set {
my($a1, $a2) = @_;
@@ -672,6 +683,6 @@
);
}
-#line 1556
+#line 1567
1;
Modified: branches/upstream/libscalar-defer-perl/current/lib/Scalar/Defer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libscalar-defer-perl/current/lib/Scalar/Defer.pm?rev=22694&op=diff
==============================================================================
--- branches/upstream/libscalar-defer-perl/current/lib/Scalar/Defer.pm (original)
+++ branches/upstream/libscalar-defer-perl/current/lib/Scalar/Defer.pm Wed Jul 2 21:58:40 2008
@@ -5,11 +5,12 @@
use warnings;
BEGIN {
- our $VERSION = '0.15';
+ our $VERSION = '0.16';
our @EXPORT = qw( lazy defer force );
our @EXPORT_OK = qw( is_deferred );
}
+use Scalar::Util;
use Exporter::Lite;
use Class::InsideOut qw( register id );
use constant DEFER_PACKAGE => '0'; # This may change soon
@@ -100,21 +101,24 @@
};
{
- foreach my $sym (grep { $_ ne 'DESTROY' } keys %UNIVERSAL::) {
+ foreach my $sym (grep { $_ ne 'DESTROY' and $_ ne 'BEGIN' and $_ ne 'END' } keys %UNIVERSAL::) {
my $code = q[
sub $sym {
if ( defined Scalar::Util::blessed($_[0]) ) {
unshift @_, Scalar::Defer::SUB_FORCE()->(shift(@_));
goto &{$_[0]->can("$sym")};
- } else {
+ }
+ else {
return shift->SUPER::$sym(@_);
}
}
];
- $code =~ s/\$sym/$sym/ge;
-
+ $code =~ s/\$sym/$sym/g;
+
+ local $@;
eval $code;
+ warn $@ if $@;
}
*DESTROY = \&Scalar::Defer::DESTROY;
More information about the Pkg-perl-cvs-commits
mailing list