@@ -1,5 +1,21 @@
Revision history for indirect
+0.31 2013-09-05 16:45 UTC
+ + Fix : [RT #88428] : no indirect in eval can trigger for direct calls
+ on __PACKAGE__
+ Thanks Graham Knop for reporting.
+ + Tst : Author tests are no longer bundled with this distribution.
+ They are only made available to authors in the git repository.
+
+0.30 2013-05-16 15:55 UTC
+ + Fix : [RT #83806] : false positives with Devel::Declare
+ [RT #83839] : false positive using ? : syntax
+ Thanks Andrew Main for the patch.
+ However, please note that the reason this patch seems to fix
+ thinks has not been explained.
+ + Fix : [RT #84649] : incorrect RT link in metadata
+ Thanks Karen Etheridge for reporting.
+
0.29 2013-03-05 01:30 UTC
+ Fix : [RT #83659] : false positives
Proper method calls in string-like environments (like
@@ -27,11 +27,7 @@ t/45-memory.t
t/46-stress.t
t/47-stress-use.t
t/50-external.t
-t/91-pod.t
-t/92-pod-coverage.t
-t/93-pod-spelling.t
-t/95-portability-files.t
-t/99-kwalitee.t
+t/51-dd-newlines.t
t/lib/Test/Leaner.pm
t/lib/VPIT/TestHelpers.pm
t/lib/indirect/Test0/Fffff/Vvvvvvv.pm
@@ -4,7 +4,7 @@
"Vincent Pit <perl@profvince.com>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921",
+ "generated_by" : "ExtUtils::MakeMaker version 6.74, CPAN::Meta::Converter version 2.132140",
"license" : [
"perl_5"
],
@@ -46,7 +46,7 @@
"release_status" : "stable",
"resources" : {
"bugtracker" : {
- "web" : "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=indirect"
+ "web" : "http://rt.cpan.org/Dist/Display.html?Name=indirect"
},
"homepage" : "http://search.cpan.org/dist/indirect/",
"license" : [
@@ -56,5 +56,5 @@
"url" : "http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git"
}
},
- "version" : "0.29"
+ "version" : "0.31"
}
@@ -12,7 +12,7 @@ configure_requires:
Config: 0
ExtUtils::MakeMaker: 0
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921'
+generated_by: 'ExtUtils::MakeMaker version 6.74, CPAN::Meta::Converter version 2.132140'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -27,8 +27,8 @@ requires:
XSLoader: 0
perl: 5.008001
resources:
- bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=indirect
+ bugtracker: http://rt.cpan.org/Dist/Display.html?Name=indirect
homepage: http://search.cpan.org/dist/indirect/
license: http://dev.perl.org/licenses/
repository: http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git
-version: 0.29
+version: 0.31
@@ -1,4 +1,4 @@
-use 5.008001;
+use 5.008_001;
use strict;
use warnings;
@@ -70,7 +70,7 @@ my %META = (
},
dynamic_config => 1,
resources => {
- bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
+ bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist",
homepage => "http://search.cpan.org/dist/$dist/",
license => 'http://dev.perl.org/licenses/',
repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git",
@@ -2,7 +2,7 @@ NAME
indirect - Lexically warn about using the indirect method call syntax.
VERSION
- Version 0.29
+ Version 0.31
SYNOPSIS
In a script :
@@ -179,7 +179,7 @@ DEPENDENCIES
A C compiler. This module may happen to build with a C++ compiler as
well, but don't rely on it, as no guarantee is made in this regard.
- Carp (standard since perl 5), XSLoader (since perl 5.006).
+ Carp (standard since perl 5), XSLoader (since perl 5.6.0).
AUTHOR
Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
@@ -523,27 +523,12 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) {
/* --- Check functions ----------------------------------------------------- */
-STATIC STRLEN indirect_nextline(const char *s, STRLEN len) {
- STRLEN i;
-
- for (i = 0; i < len; ++i) {
- if (s[i] == '\n') {
- ++i;
- while (i < len && s[i] == '\r')
- ++i;
- break;
- }
- }
-
- return i;
-}
-
STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
#define indirect_find(NSV, LBP, NP) indirect_find(aTHX_ (NSV), (LBP), (NP))
STRLEN name_len, line_len;
const char *name, *name_end;
const char *line, *line_end;
- const char *p, *t, *u;
+ const char *p;
line = SvPV_const(PL_linestr, line_len);
line_end = line + line_len;
@@ -572,26 +557,7 @@ STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *nam
++p;
}
- t = line;
- u = t;
-
- /* If we're inside a string-like environment, we don't need to be smart for
- * finding the positions of the tokens : as the line number will always be
- * the line where the string began (or at least I hope so), and the line
- * buffer points to the beginning of the string (likewise), we can just take
- * the offset in this string as the position. */
- if (!PL_lex_inwhat) {
- while (t <= p) {
- STRLEN i = indirect_nextline(t, line_len);
- if (i >= line_len)
- break;
- u = t;
- t += i;
- line_len -= i;
- }
- }
-
- *name_pos = p - u;
+ *name_pos = p - line;
return 1;
}
@@ -610,6 +576,25 @@ STATIC OP *indirect_ck_const(pTHX_ OP *o) {
STRLEN pos;
if (indirect_find(sv, PL_oldbufptr, &pos)) {
+ STRLEN len;
+
+ /* If the constant is equal to the current package name, try to look for
+ * a "__PACKAGE__" coming before what we got. We only need to check this
+ * when we already had a match because __PACKAGE__ can only appear in
+ * direct method calls ("new __PACKAGE__" is a syntax error). */
+ len = SvCUR(sv);
+ if (len == HvNAMELEN_get(PL_curstash)
+ && memcmp(SvPVX(sv), HvNAME_get(PL_curstash), len) == 0) {
+ STRLEN pos_pkg;
+ SV *pkg = sv_newmortal();
+ sv_setpvn(pkg, "__PACKAGE__", sizeof("__PACKAGE__")-1);
+
+ if (indirect_find(pkg, PL_oldbufptr, &pos_pkg) && pos_pkg < pos) {
+ sv = pkg;
+ pos = pos_pkg;
+ }
+ }
+
indirect_map_store(o, pos, sv, CopLINE(&PL_compiling));
return o;
}
@@ -1,6 +1,6 @@
package indirect;
-use 5.008001;
+use 5.008_001;
use strict;
use warnings;
@@ -11,13 +11,13 @@ indirect - Lexically warn about using the indirect method call syntax.
=head1 VERSION
-Version 0.29
+Version 0.31
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.29';
+ $VERSION = '0.31';
}
=head1 SYNOPSIS
@@ -260,7 +260,7 @@ L<perl> 5.8.1.
A C compiler.
This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
-L<Carp> (standard since perl 5), L<XSLoader> (since perl 5.006).
+L<Carp> (standard since perl 5), L<XSLoader> (since perl 5.6.0).
=head1 AUTHOR
@@ -5,7 +5,7 @@ use warnings;
use Test::More tests => 1;
BEGIN {
- use_ok( 'indirect' );
+ use_ok( 'indirect' );
}
diag( "Testing indirect $indirect::VERSION, Perl $], $^X" );
@@ -1,6 +1,6 @@
#!perl -T
-package Dongs;
+package NotEmpty;
sub new;
@@ -9,7 +9,7 @@ package main;
use strict;
use warnings;
-use Test::More tests => 109 * 8 + 10;
+use Test::More tests => 119 * 8 + 10;
BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
@@ -46,6 +46,9 @@ SKIP:
skip "$_: $skip" => 8 if eval $skip;
{
+ local $_ = $_;
+ s/Pkg/Empty/g;
+
try "return; $prefix; use indirect; $_";
is $@, '', "use indirect: $_";
is @warns, 0, 'no reports';
@@ -57,7 +60,7 @@ SKIP:
{
local $_ = $_;
- s/Hlagh/Dongs/g;
+ s/Pkg/NotEmpty/g;
try "return; $prefix; use indirect; $_";
is $@, '', "use indirect, defined: $_";
@@ -165,37 +168,37 @@ SKIP:
__DATA__
-$obj = Hlagh->new;
+$obj = Pkg->new;
####
-$obj = Hlagh->new();
+$obj = Pkg->new();
####
-$obj = Hlagh->new(1);
+$obj = Pkg->new(1);
####
-$obj = Hlagh->new(q{foo}, bar => $obj);
+$obj = Pkg->new(q{foo}, bar => $obj);
####
-$obj = Hlagh -> new ;
+$obj = Pkg -> new ;
####
-$obj = Hlagh -> new ( ) ;
+$obj = Pkg -> new ( ) ;
####
-$obj = Hlagh -> new ( 1 ) ;
+$obj = Pkg -> new ( 1 ) ;
####
-$obj = Hlagh -> new ( 'foo' , bar => $obj );
+$obj = Pkg -> new ( 'foo' , bar => $obj );
####
-$obj = Hlagh
+$obj = Pkg
->
new ;
####
-$obj = Hlagh
+$obj = Pkg
->
new (
) ;
####
-$obj = Hlagh
+$obj = Pkg
-> new (
1 ) ;
####
-$obj = Hlagh ->
+$obj = Pkg ->
new ( "foo"
, bar
=> $obj );
@@ -208,17 +211,17 @@ $obj = new->newnew;
####
$obj = newnew->new;
####
-$obj = Hlagh->$cb;
+$obj = Pkg->$cb;
####
-$obj = Hlagh->$cb();
+$obj = Pkg->$cb();
####
-$obj = Hlagh->$cb($pkg);
+$obj = Pkg->$cb($pkg);
####
-$obj = Hlagh->$cb(sub { 'foo' }, bar => $obj);
+$obj = Pkg->$cb(sub { 'foo' }, bar => $obj);
####
-$obj = Hlagh->$meth;
+$obj = Pkg->$meth;
####
-$obj = Hlagh
+$obj = Pkg
->
$meth ( 1, 2 );
####
@@ -299,11 +302,11 @@ print $x "oh hai\n";
####
print $y;
####
-print $y "dongs\n";
+print $y "hello thar\n";
#### "$]" < 5.010 # use feature 'state'; state $z
print $z;
#### "$]" < 5.010 # use feature 'state'; state $z
-print $z "hlagh\n";
+print $z "lolno\n";
####
print STDOUT "bananananananana\n";
####
@@ -333,17 +336,17 @@ $obj = "apple ${\($y->$meth)} pear"
####
$obj = "apple @{[$y->$meth]} pear"
#### # local $_ = "foo";
-s/foo/return; Hlagh->new/e;
+s/foo/return; Pkg->new/e;
#### # local $_ = "bar";
-s/foo/return; Hlagh->new/e;
+s/foo/return; Pkg->new/e;
#### # local $_ = "foo";
-s/foo/return; Hlagh->$cb/e;
+s/foo/return; Pkg->$cb/e;
#### # local $_ = "bar";
-s/foo/return; Hlagh->$cb/e;
+s/foo/return; Pkg->$cb/e;
#### # local $_ = "foo";
-s/foo/return; Hlagh->$meth/e;
+s/foo/return; Pkg->$meth/e;
#### # local $_ = "bar";
-s/foo/return; Hlagh->$meth/e;
+s/foo/return; Pkg->$meth/e;
#### # local $_ = "foo";
s/foo/return; $x->new/e;
#### # local $_ = "bar";
@@ -369,11 +372,11 @@ s/foo/return; $y->$meth/e;
#### # local $_ = "bar";
s/foo/return; $y->$meth/e;
####
-"foo" =~ /(?{Hlagh->new})/;
+"foo" =~ /(?{Pkg->new})/;
####
-"foo" =~ /(?{Hlagh->$cb})/;
+"foo" =~ /(?{Pkg->$cb})/;
####
-"foo" =~ /(?{Hlagh->$meth})/;
+"foo" =~ /(?{Pkg->$meth})/;
####
"foo" =~ /(?{$x->new})/;
####
@@ -403,26 +406,63 @@ zap { 1; 1; };
####
zap { zap { }; 1; };
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
####
-my @stuff = sort Hlagh
+my @stuff = sort Pkg
->new;
+####
+sub {
+ my $self = shift;
+ return $self->new ? $self : undef;
+}
+####
+sub {
+ my $self = shift;
+ return $self ? $self->new : undef;
+}
+####
+sub {
+ my $self = shift;
+ return $_[0] ? undef : $self->new;
+}
+####
+package Hurp;
+__PACKAGE__->new;
+####
+package Hurp;
+__PACKAGE__->new # Hurp
+####
+package Hurp;
+__PACKAGE__->new;
+# Hurp
+####
+package __PACKAGE_;
+__PACKAGE__->new # __PACKAGE_
+####
+package __PACKAGE_;
+__PACKAGE_->new # __PACKAGE__
+####
+package __PACKAGE___;
+__PACKAGE__->new # __PACKAGE___
+####
+package __PACKAGE___;
+__PACKAGE___->new # __PACKAGE__
@@ -1,6 +1,6 @@
#!perl -T
-package Dongs;
+package NotEmpty;
sub new;
@@ -11,8 +11,8 @@ use warnings;
my ($tests, $reports);
BEGIN {
- $tests = 82;
- $reports = 94;
+ $tests = 88;
+ $reports = 100;
}
use Test::More tests => 3 * (4 * $tests + $reports) + 4;
@@ -62,12 +62,18 @@ sub try {
SKIP:
{
- my ($code, $expected) = split /^-{4,}$/m, $_, 2;
- my @expected = expect($expected);
-
- skip "$_: $skip" => 3 * (4 + @expected) if eval $skip;
+ if (do { local $@; eval $skip }) {
+ my ($code, $expected) = split /^-{4,}$/m, $_, 2;
+ my @expected = expect($expected);
+ skip "$_: $skip" => 3 * (4 + @expected);
+ }
{
+ local $_ = $_;
+ s/Pkg/Empty/g;
+ my ($code, $expected) = split /^-{4,}$/m, $_, 2;
+ my @expected = expect($expected);
+
try "return; $prefix; use indirect; $code";
is $@, '', "use indirect: $code";
is @warns, 0, 'correct number of reports';
@@ -82,7 +88,7 @@ SKIP:
{
local $_ = $_;
- s/Hlagh/Dongs/g;
+ s/Pkg/NotEmpty/g;
my ($code, $expected) = split /^-{4,}$/m, $_, 2;
my @expected = expect($expected);
@@ -100,9 +106,12 @@ SKIP:
SKIP:
{
+ local $_ = $_;
+ s/Pkg/Empty/g;
+ my ($code, $expected) = split /^-{4,}$/m, $_, 2;
+ my @expected = expect($expected);
skip 'No space tests on perl 5.11' => 4 + @expected
if "$]" >= 5.011 and "$]" < 5.012;
- my $code = $code;
$code =~ s/\$/\$ \n\t /g;
try "return; $prefix; use indirect; $code";
@@ -124,80 +133,80 @@ eval {
my @warns;
{
local $SIG{__WARN__} = sub { push @warns, @_ };
- eval "return; no indirect 'hlagh'; \$obj = new Hlagh1;";
+ eval "return; no indirect 'whatever'; \$obj = new Pkg1;";
}
- is $@, '', 'no indirect "hlagh" didn\'t croak';
+ is $@, '', 'no indirect "whatever" didn\'t croak';
is @warns, 1, 'only one warning';
my $warn = shift @warns;
- like $warn, qr/^Indirect call of method "new" on object "Hlagh1"/,
- 'no indirect "hlagh" enables the pragma';
+ like $warn, qr/^Indirect call of method "new" on object "Pkg1"/,
+ 'no indirect "whatever" enables the pragma';
is_deeply \@warns, [ ], 'nothing more';
}
__DATA__
-$obj = new Hlagh;
+$obj = new Pkg;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh if 0;
+$obj = new Pkg if 0;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh();
+$obj = new Pkg();
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh(1);
+$obj = new Pkg(1);
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh(1, 2);
+$obj = new Pkg(1, 2);
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh ;
+$obj = new Pkg ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh ( ) ;
+$obj = new Pkg ( ) ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh ( 1 ) ;
+$obj = new Pkg ( 1 ) ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = new Hlagh ( 1 , 2 ) ;
+$obj = new Pkg ( 1 , 2 ) ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
$obj = new
- Hlagh
+ Pkg
;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
$obj = new
- Hlagh (
+ Pkg (
) ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
$obj =
new
- Hlagh ( 1
+ Pkg ( 1
) ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
$obj =
new
-Hlagh
+Pkg
( 1 ,
2 ) ;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
$obj = new $x;
----
@@ -327,25 +336,25 @@ meh $sploosh::sploosh;
----
[ 'meh', '$sploosh::sploosh' ]
####
-new Hlagh->wut;
+new Pkg->wut;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-new Hlagh->wut();
+new Pkg->wut();
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-new Hlagh->wut, "Wut";
+new Pkg->wut, "Wut";
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = HlaghHlagh Hlagh;
+$obj = PkgPkg Pkg;
----
-[ 'HlaghHlagh', 'Hlagh' ]
+[ 'PkgPkg', 'Pkg' ]
####
-$obj = HlaghHlagh Hlagh; # HlaghHlagh Hlagh
+$obj = PkgPkg Pkg; # PkgPkg Pkg
----
-[ 'HlaghHlagh', 'Hlagh' ]
+[ 'PkgPkg', 'Pkg' ]
####
$obj = new newnew;
----
@@ -363,21 +372,21 @@ $obj = feh feh; # feh feh
----
[ 'feh', 'feh' ]
####
-new Hlagh (meh $x)
+new Pkg (meh $x)
----
-[ 'meh', '$x' ], [ 'new', 'Hlagh' ]
+[ 'meh', '$x' ], [ 'new', 'Pkg' ]
####
-Hlagh->new(meh $x)
+Pkg->new(meh $x)
----
[ 'meh', '$x' ]
####
-$obj = "apple ${\(new Hlagh)} pear"
+$obj = "apple ${\(new Pkg)} pear"
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
-$obj = "apple @{[new Hlagh]} pear"
+$obj = "apple @{[new Pkg]} pear"
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
$obj = "apple ${\(new $x)} pear"
----
@@ -403,13 +412,13 @@ $obj = "apple @{[new $x qq|@{[stuff $y]}|]} pear"
----
[ 'stuff', '$y' ], [ 'new', '$x' ]
#### # local $_ = "foo";
-s/foo/return; new Hlagh/e;
+s/foo/return; new Pkg/e;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
#### # local $_ = "bar";
-s/foo/return; new Hlagh/e;
+s/foo/return; new Pkg/e;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
#### # local $_ = "foo";
s/foo/return; new $x/e;
----
@@ -427,9 +436,9 @@ s/foo/return; new $y/e;
----
[ 'new', '$y' ]
####
-"foo" =~ /(?{new Hlagh})/;
+"foo" =~ /(?{new Pkg})/;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
"foo" =~ /(?{new $x})/;
----
@@ -439,9 +448,9 @@ s/foo/return; new $y/e;
----
[ 'new', '$y' ]
####
-"foo" =~ /(??{new Hlagh})/;
+"foo" =~ /(??{new Pkg})/;
----
-[ 'new', 'Hlagh' ]
+[ 'new', 'Pkg' ]
####
"foo" =~ /(??{new $x})/;
----
@@ -468,15 +477,15 @@ meh {
----
[ 'meh', '{' ]
####
-meh { new Hlagh; 1; };
+meh { new Pkg; 1; };
----
-[ 'new', 'Hlagh' ], [ 'meh', '{' ]
+[ 'new', 'Pkg' ], [ 'meh', '{' ]
####
meh { feh $x; 1; };
----
[ 'feh', '$x' ], [ 'meh', '{' ]
####
-meh { feh $x; use indirect; new Hlagh; 1; };
+meh { feh $x; use indirect; new Pkg; 1; };
----
[ 'feh', '$x' ], [ 'meh', '{' ]
####
@@ -484,10 +493,40 @@ meh { feh $y; 1; };
----
[ 'feh', '$y' ], [ 'meh', '{' ]
####
-meh { feh $x; 1; } new Hlagh, feh $y;
+meh { feh $x; 1; } new Pkg, feh $y;
----
-[ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]
+[ 'feh', '$x' ], [ 'new', 'Pkg' ], [ 'feh', '$y' ], [ 'meh', '{' ]
####
$obj = "apple @{[new { feh $x; meh $y; 1 }]} pear"
----
[ 'feh', '$x' ], [ 'meh', '$y' ], [ 'new', '{' ]
+####
+package __PACKAGE_;
+new __PACKAGE_;
+----
+[ 'new', '__PACKAGE_' ]
+####
+package __PACKAGE___;
+new __PACKAGE___;
+----
+[ 'new', '__PACKAGE___' ]
+####
+package Hurp;
+new { __PACKAGE__ }; # Hurp
+----
+[ 'new', '{' ]
+####
+package __PACKAGE_;
+new { __PACKAGE__ };
+----
+[ 'new', '{' ]
+####
+package __PACKAGE__;
+new { __PACKAGE__ };
+----
+[ 'new', '{' ]
+####
+package __PACKAGE___;
+new { __PACKAGE__ };
+----
+[ 'new', '{' ]
@@ -1,6 +1,6 @@
#!perl -T
-package Dongs;
+package NotEmpty;
sub new;
@@ -40,9 +40,12 @@ sub try {
SKIP:
{
- skip "$_: $skip" => 9 if eval $skip;
+ skip "$_: $skip" => 9 if do { local $@; eval $skip };
{
+ local $_ = $_;
+ s/Pkg/Empty/g;
+
try "return; $prefix; use indirect; $_";
is $@, '', "use indirect: $_";
is @warns, 0, 'correct number of reports';
@@ -54,7 +57,7 @@ SKIP:
{
local $_ = $_;
- s/Hlagh/Dongs/g;
+ s/Pkg/NotEmpty/g;
try "return; $prefix; use indirect; $_";
is $@, '', "use indirect, defined: $_";
@@ -63,7 +66,7 @@ SKIP:
try "return; $prefix; no indirect; $_";
is $@, '', "use indirect, defined: $_";
is @warns, 1, 'correct number of reports';
- like $warns[0], qr/^Indirect call of method "meh" on object "Dongs" at \(eval \d+\) line \d+/, 'report 0 is correct';
+ like $warns[0], qr/^Indirect call of method "meh" on object "NotEmpty" at \(eval \d+\) line \d+/, 'report 0 is correct';
}
}
}
@@ -71,8 +74,8 @@ SKIP:
__DATA__
-meh Hlagh->new;
+meh Pkg->new;
####
-meh Hlagh->new();
+meh Pkg->new();
####
-meh Hlagh->new, "Wut";
+meh Pkg->new, "Wut";
@@ -75,7 +75,7 @@ sub expect {
}
}
is $@, '', "no indirect; eval 'my \$x = new Bar'";
- if ("$]" < 5.009005) {
+ if ("$]" < 5.009_005) {
is @w, 0, 'no warnings caught';
pass 'placeholder';
} else {
@@ -87,7 +87,7 @@ sub expect {
SKIP: {
skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 2
- if "$]" < 5.009005;
+ if "$]" < 5.009_005;
my @w;
my $test = sub { eval 'return; new XYZ' };
{
@@ -118,13 +118,13 @@ SKIP: {
eval "return; no indirect; use indirect::TestRequired2; my \$x = new Bar;";
}
is $@, '', 'second require test doesn\'t croak prematurely';
- @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008003;
+ @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008_003;
my $w = shift @w;
like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'),
'second require test caught error for Baz';
SKIP: {
skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1
- if "$]" < 5.009005;
+ if "$]" < 5.009_005;
$w = shift @w;
like $w, expect('Blech'), 'second require test caught error for Blech';
}
@@ -148,7 +148,7 @@ SKIP: {
new indirect::TestRequired3Z;
}
TESTREQUIRED3
- @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008003;
+ @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008_003;
is $@, '',
"pragma leak when reusing callback test doesn't croak prematurely";
is_deeply \@w, [ ],
@@ -21,7 +21,7 @@ sub run_perl {
SKIP:
{
- skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008002;
+ skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002;
my $status = run_perl <<' RUN';
my ($code, @expected);
@@ -0,0 +1,33 @@
+#!perl
+
+use lib 't/lib';
+use VPIT::TestHelpers;
+
+BEGIN {
+ load_or_skip_all("Devel::Declare", 0.006007, undef);
+}
+
+use Test::More tests => 1;
+
+sub foo { }
+
+sub foo_magic {
+ my($declarator, $offset) = @_;
+ $offset += Devel::Declare::toke_move_past_token($offset);
+ my $linestr = Devel::Declare::get_linestr();
+ substr $linestr, $offset, 0, "\n\n";
+ Devel::Declare::set_linestr($linestr);
+}
+
+BEGIN {
+ Devel::Declare->setup_for("main", { foo => { const => \&foo_magic } });
+}
+
+no indirect ":fatal";
+
+sub bar {
+ my $x;
+ foo; $x->m;
+}
+
+ok 1;
@@ -1,15 +0,0 @@
-#!perl -T
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib 't/lib';
-use VPIT::TestHelpers;
-
-load_or_skip_all('Test::Pod', '1.22', [ ]);
-
-eval 'use Test::Pod'; # Make Kwalitee test happy
-
-all_pod_files_ok();
@@ -1,16 +0,0 @@
-#!perl -T
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib 't/lib';
-use VPIT::TestHelpers;
-
-load_or_skip_all('Test::Pod::Coverage', '1.08', [ ]);
-load_or_skip_all('Pod::Coverage', '0.18' );
-
-eval 'use Test::Pod::Coverage'; # Make Kwalitee test happy
-
-all_pod_coverage_ok( { also_private => [ qr/^_/, qr/^CLONE(_SKIP)?$/ ] } );
@@ -1,13 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib 't/lib';
-use VPIT::TestHelpers;
-
-load_or_skip_all('Test::Pod::Spelling::CommonMistakes', '1.0', [ ]);
-
-all_pod_files_ok();
@@ -1,13 +0,0 @@
-#!perl -T
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib 't/lib';
-use VPIT::TestHelpers;
-
-load_or_skip_all('Test::Portability::Files', undef, [ ]);
-
-run_tests();
@@ -1,29 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib 't/lib';
-use VPIT::TestHelpers;
-
-my $guard = VPIT::TestHelpers::Guard->new(
- sub { unlink for glob 'Debian_CPANTS.txt*' }
-);
-
-load_or_skip_all('Parse::RecDescent', '1.967006');
-load_or_skip_all('Module::ExtractUse', '0.24' );
-load_or_skip_all('Test::Kwalitee', '1.01' );
-
-SKIP: {
- eval { Test::Kwalitee->import(); };
- if (my $err = $@) {
- 1 while chomp $err;
- require Test::Builder;
- my $Test = Test::Builder->new;
- my $plan = $Test->has_plan;
- $Test->skip_all($err) if not defined $plan or $plan eq 'no_plan';
- skip $err => $plan - $Test->current_test;
- }
-}
@@ -10,11 +10,11 @@ Test::Leaner - A slimmer Test::More for when you favor performance over complete
=head1 VERSION
-Version 0.04
+Version 0.05
=cut
-our $VERSION = '0.04';
+our $VERSION = '0.05';
=head1 SYNOPSIS
@@ -273,7 +273,11 @@ sub _sanitize_comment {
The following functions from L<Test::More> are implemented and exported by default.
-=head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
+=head2 C<plan>
+
+ plan tests => $count;
+ plan 'no_plan';
+ plan skip_all => $reason;
See L<Test::More/plan>.
@@ -336,7 +340,9 @@ sub import {
goto &Exporter::import;
}
-=head2 C<< skip $reason => $count >>
+=head2 C<skip>
+
+ skip $reason => $count;
See L<Test::More/skip>.
@@ -373,7 +379,10 @@ sub skip {
last SKIP;
}
-=head2 C<done_testing [ $count ]>
+=head2 C<done_testing>
+
+ done_testing;
+ done_testing $count;
See L<Test::More/done_testing>.
@@ -406,7 +415,10 @@ sub done_testing {
return 1;
}
-=head2 C<ok $ok [, $desc ]>
+=head2 C<ok>
+
+ ok $ok;
+ ok $ok, $desc;
See L<Test::More/ok>.
@@ -435,7 +447,10 @@ sub ok ($;$) {
return $ok;
}
-=head2 C<pass [ $desc ]>
+=head2 C<pass>
+
+ pass;
+ pass $desc;
See L<Test::More/pass>.
@@ -446,7 +461,10 @@ sub pass (;$) {
goto &ok;
}
-=head2 C<fail [ $desc ]>
+=head2 C<fail>
+
+ fail;
+ fail $desc;
See L<Test::More/fail>.
@@ -457,7 +475,10 @@ sub fail (;$) {
goto &ok;
}
-=head2 C<is $got, $expected [, $desc ]>
+=head2 C<is>
+
+ is $got, $expected;
+ is $got, $expected, $desc;
See L<Test::More/is>.
@@ -473,7 +494,10 @@ sub is ($$;$) {
goto &ok;
}
-=head2 C<isnt $got, $expected [, $desc ]>
+=head2 C<isnt>
+
+ isnt $got, $expected;
+ isnt $got, $expected, $desc;
See L<Test::More/isnt>.
@@ -560,11 +584,17 @@ IS_BINOP
}
}
-=head2 C<like $got, $regexp_expected [, $desc ]>
+=head2 C<like>
+
+ like $got, $regexp_expected;
+ like $got, $regexp_expected, $desc;
See L<Test::More/like>.
-=head2 C<unlike $got, $regexp_expected, [, $desc ]>
+=head2 C<unlike>
+
+ unlike $got, $regexp_expected;
+ unlike $got, $regexp_expected, $desc;
See L<Test::More/unlike>.
@@ -576,7 +606,10 @@ See L<Test::More/unlike>.
*unlike = _create_binop_handler('!~');
}
-=head2 C<cmp_ok $got, $op, $expected [, $desc ]>
+=head2 C<cmp_ok>
+
+ cmp_ok $got, $op, $expected;
+ cmp_ok $got, $op, $expected, $desc;
See L<Test::More/cmp_ok>.
@@ -593,7 +626,10 @@ sub cmp_ok ($$$;$) {
goto $handler;
}
-=head2 C<is_deeply $got, $expected [, $desc ]>
+=head2 C<is_deeply>
+
+ is_deeply $got, $expected;
+ is_deeply $got, $expected, $desc;
See L<Test::More/is_deeply>.
@@ -735,7 +771,9 @@ sub _diag_fh {
return 0;
};
-=head2 C<diag @text>
+=head2 C<diag>
+
+ diag @lines;
See L<Test::More/diag>.
@@ -746,7 +784,9 @@ sub diag {
goto &_diag_fh;
}
-=head2 C<note @text>
+=head2 C<note>
+
+ note @lines;
See L<Test::More/note>.
@@ -757,7 +797,10 @@ sub note {
goto &_diag_fh;
}
-=head2 C<BAIL_OUT [ $desc ]>
+=head2 C<BAIL_OUT>
+
+ BAIL_OUT;
+ BAIL_OUT $desc;
See L<Test::More/BAIL_OUT>.
@@ -802,7 +845,10 @@ END {
L<Test::Leaner> also provides some functions of its own, which are never exported.
-=head2 C<tap_stream [ $fh ]>
+=head2 C<tap_stream>
+
+ my $tap_fh = tap_stream;
+ tap_stream $fh;
Read/write accessor for the filehandle to which the tests are outputted.
On write, it also turns autoflush on onto C<$fh>.
@@ -827,7 +873,10 @@ sub tap_stream (;*) {
tap_stream *STDOUT;
-=head2 C<diag_stream [ $fh ]>
+=head2 C<diag_stream>
+
+ my $diag_fh = diag_stream;
+ diag_stream $fh;
Read/write accessor for the filehandle to which the diagnostics are printed.
On write, it also turns autoflush on onto C<$fh>.
@@ -882,7 +931,7 @@ You can find documentation for this module with the perldoc command.
=head1 COPYRIGHT & LICENSE
-Copyright 2010,2011 Vincent Pit, all rights reserved.
+Copyright 2010,2011,2013 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
@@ -18,7 +18,7 @@ sub import {
skip_all 'This perl wasn\'t built to support threads'
unless $Config{useithreads};
skip_all 'perl 5.13.4 required to test thread safety'
- unless $force or "$]" >= 5.013004;
+ unless $force or "$]" >= 5.013_004;
load_or_skip_all('threads', $force ? '0' : '1.67', [ ]);